diff options
author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-06 17:50:16 +0000 |
---|---|---|
committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-06 17:50:16 +0000 |
commit | 5ac2026f7eed78958d69d051e7a8e993dcf51205 (patch) | |
tree | 298c3d2f08bdfe5689998b11892d72a897985be1 | |
download | Moose-tarball-master.tar.gz |
Moose-2.1405HEADMoose-2.1405master
1041 files changed, 143765 insertions, 0 deletions
@@ -0,0 +1,4593 @@ +Also see Moose::Manual::Delta for more details of, and workarounds +for, noteworthy changes. + +2.1405 2015-06-06 + + [BUG FIXES] + + - The native 'Array' trait 'sort' accessor now returns the number of + elements in scalar context, instead of the undefined value (or a + different, seemingly-random, value under 5.23.x). + +2.1404 2015-04-16 + + [BUG FIXES] + + - Add Sub::Identify to prereqs. (RT #101661) + - bump List::Util prereq to avoid a memory leak (RT#101124) + + [DOCUMENTATION] + + - Added section to Moose::Manual::Resources to list external links related + to Moose (RT #101993, Michael LaGrasta) + +2.1403 2014-12-07 + + [DOCUMENTATION] + + - Added a section to Moose::Manual::MethodModifiers illustrating how method + modifiers work with inheritance. (Andreas Koenig, RT #98940) + - Added docs to Moose.pm on the -meta_name import option. This addresses RT + #98488. + + [BUG FIXES] + + - Fix a test that fails on MSWin32 systems using nmake + - fix dev build compilation error when using MSVC (A. Sinan Unur) + + [OTHER] + + - the modules in the git repository now have a defined $VERSION, to make it + easier to test MooseX::* and other code under development. + +2.1402 2014-11-05 + + [BUG FIXES] + + - Fix a test that was trying to load Test::Exception instead of Test::Fatal. + (Michael Schout) + +2.1401 2014-11-03 + + [BUG FIXES] + + - The core overloading support interacted badly with + MooseX::MarkAsMethods. If you used MooseX::MarkAsMethods in a role that + provided overloading, then that overloading would not be properly applied + to consuming classes, leading to very weird errors of the form: + + Can't resolve method "???" overloading """" in package "Class2" ... + + Note that the problems that MooseX::MarkAsMethods fixes are no longer + present if you are using Moose 2.1400+ and namespace::autoclean 0.16+. We + encourage you to upgrade both of these modules and remove + MooseX::MarkAsMethods from your code base. + +2.1400 2014-10-31 + + [BUG FIXES] + + - Moose exception classes now stringify all stack frames, to avoid issues + in global destruction (see RT#99811) + +2.1307 2014-10-26 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - Support added to Moose::Exporter for exporting subs by their fully + qualified name, as well as coderefs. This avoids internal breakage if some + other module has monkey-patched a sub to be exported and left it anonymous + (e.g. RT#88669). (Graham Knop, PR#84) + + [BUG FIXES] + + - Further refined the overloading fixes from 2.1306, fixing fallback + handling on older perl versions (Dave Rolsky, PR#85) + +2.1306 2014-10-25 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - Rewrote overloading implementation to use a new Class::MOP::Overload + object. This object properly captures all overloading information. The + Class::MOP::Method::Overload class has been removed. (Dave Rolsky, PR#83) + + [BUG FIXES] + + - If a role had method-based overloading but did not actually implement the + specified method, its overloading was simply ignored when applying + overloading to other roles or classes. Reported by rjbs. RT #98531. + +2.1305 2014-10-22 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - By default, exceptions thrown from inside Moose now remove most of the + Moose internals from their stack trace when stringifying. This makes for + much more readable error messages in most cases. Set the + MOOSE_FULL_EXCEPTION env var to true to get the complete stack trace. + +2.1304 2014-09-25 (TRIAL RELEASE) + + [BUG FIXES] + + - closed a memory leak in Moose exception objects where captured stack + trace frames would contain circular references to the exception objects + themselves (Graham Knop, PR#81) + +2.1303 2014-09-19 (TRIAL RELEASE) + + [TEST FIXES] + + - fix tests that fail on altered warning messages in perl 5.21.4 (RT#98987) + +2.1302 2014-08-19 (TRIAL RELEASE) + + [BUG FIXES] + + - When a role consumes another role and they differ in their overloading + fallback settings, the consuming role now silently wins instead of + throwing an exception. This is consistent with how other + role-consumes-role conflicts are handled. + - Fixed the docs for overloading conflicts to match reality. + +2.1301 2014-08-19 (TRIAL RELEASE) + + [BUG FIXES] + + - Conflict detection for overloading operators is now more correct. If a + class consumed two roles that both had identical overloading methods + (because they got them from some other role, for example), this caused an + error, but it shouldn't. GH #4. (rjbs) + - Similarly, when a role consumes another role, conflicts in overloading + operators are now silently resolved in favor of the consuming role, just + as they are with methods. Note that conflicts between the fallback setting + for roles are still an error. + +2.1300 2014-08-11 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - Moose now has core support for overloading in roles. When a role with + overloading is applied to classes or other roles, the overloading settings + are transferred to the consumer. Conflicts between roles are treated much + like method conflicts. This obviates the need for + MooseX::Role::WithOverloading. If you are using + MooseX::Role::WithOverloading, upgrade to version 0.15+ and it will simply + become a no-op when used with this version of Moose. + + [OTHER] + + - The overloading info methods for roles and classes no longer treat + "fallback" as an overloaded op. Instead, there are new + get_overload_fallback_value() and set_overload_fallback_value() methods to + deal with this explicitly. This is arguably a bug fix. + +2.1213 2014-09-25 + + [BUG FIXES] + + - closed a memory leak in Moose exception objects where captured stack + trace frames would contain circular references to the exception objects + themselves (Graham Knop, PR#81) + +2.1212 2014-09-19 + + [TEST FIXES] + + - fix tests that fail on altered warning messages in perl 5.21.4 (RT#98987) + +2.1211 2014-08-11 + + [DOCUMENTATION] + + - Updated Changes and Moose::Manual::Delta to note when we started removing + lazy_build from docs. Also added a note in the Moose::Meta::Attribute docs + stating that use of this feature is discouraged. + - Added a pointer from the auto_deref feature to + Moose::Meta::Attribute::Native. This is often a better choice. + + [OTHER] + + - The subs installed by Moose::Exporter->setup_import_methods are now named + using Sub::Name (Dave Rolsky, RT#97572) + +2.1210 2014-07-03 + + [DOCUMENTATION] + + - Clarify that Moose::Exception exists for internal usage and that user + code is better off using the Throwable role or Throwable::Error superclass. + - Moose::Manual::Support policy clarified regarding legacy Perl versions + + [OTHER] + + - logic has been removed for an alpha branch of Test::Builder that will + never see the light of day, and will break with upcoming Test::Builder + changes (Exodist) + +2.1209 2014-06-04 + + [OTHER] + + - The is_anon method now always returns false when called on + Moose::Meta::Role::Composite objects. This isn't strictly right, but for + the purposes of Moose internals, where "is_anon" really means "needs to be + cleaned up", it's correct. This fixes warnings that were seen when using + recent Moose (2.1100+) and MooseX::Role::Parameterized roles as part of a + composite role. These warnings only appear with Perl 5.16 and earlier. + +2.1208 2014-06-01 + + [BUG FIXES] + + - fix implementation of throw_exception in internal Class::MOP traits, + caused by changes in 2.1207 (ether, RT#96112) + +2.1207 2014-05-26 + + [OTHER] + + - Fixed Specio support to work with the latest Specio (0.10). This version of + Specio no longer uses Moose internally. + - exceptions in Class::MOP no longer use Moose::Util, instead using their + own private implementation of throw_exception, to avoid needless premature + loading of Moose logic. + +2.1206 2014-05-14 + + [BUG FIXES] + + - exceptions should not throw other exceptions; fixes cases where exceptions + were reporting the wrong error (Upasana, RT#92818 and RT#94795) + + [OTHER] + + - prereqs needed strictly for building with Dist::Zilla have been moved from + develop requires to develop recommends, to simplify automated testing on + older perls that cannot install all Dist::Zilla components + - removed instances of metaobjects in exception classes where they're not + really required + +2.1205 2014-04-15 + + [ENHANCEMENTS] + + - new utility interface: Moose::Util::is_role + + [BUG FIXES] + + - better error message provided when trying to load a trait class that does + not exist in @INC (Upasana, RT#94731) + + [OTHER] + + - new test added, to run last, which runs `moose-outdated` as a possibly + more visible mechanism to provide important information to the user + (re RT#92780) + +2.1204 2014-02-06 + + [BUG FIXES] + + - bump minimum prereq needed for optional test using MooseX::NonMoose (which + broke with new Module::Runtime, see 2.1203), so users can install Moose + and pass tests before updating MooseX::NonMoose. + +2.1203 2014-02-06 + + [BUG FIXES] + + - bump prereq on Module::Runtime to properly detect when a module fails to + load, and fix how we call these subs (Zefram, RT#92770, RT#86394, RT#92791) + + [ENHANCEMENTS] + + - line numbers in shipped code are now almost the same (within 3) as the + repository source, for easier debugging + +2.1202 2014-01-19 + + [BUG FIXES] + + - string comparisons are now possible with Moose exceptions (RT#92232) + +2.1201 2014-01-11 + + [OTHER] + + - re-release to index pod files (Moose::Cookbook::*, Moose::Manual::* etc). + +2.1200 2014-01-06 + + [OTHER] + + - Releasing 2.1108 as stable (last stable release was 2.1005). + +2.1108 2014-01-04 (TRIAL RELEASE) + + [OTHER] + - fixed distribution manifest + - minor documentation and metadata updates + +2.1107 2013-11-29 (TRIAL RELEASE) + + [OTHER] + + - many additions to the list of conflicting modules (those that require + updates after installing Moose), reflecting recent API changes + - now failing early at build time, with a useful error message, if a + compiler is not available + +2.1106 2013-11-05 (TRIAL RELEASE) + + [BUG FIXES] + + - throw_error import cleaned from Moose::Object after use (doy) + - resolved new circular load issue between Moose::Util and Class::MOP (Kent + Fredric, RT#89713 and PR#42) + +2.1105 2013-10-30 (TRIAL RELEASE) + + [BUG FIXES] + + - legacy throw_error now takes multiple arguments, like confess does + (Karen Etheridge) + +2.1104 2013-10-29 (TRIAL RELEASE) + + [BUG FIXES] + + - Class::MOP::Object::_inline_throw_error is back, used by some MooseX + modules (Upasana) + +2.1103 2013-10-25 (TRIAL RELEASE) + + [BUG FIXES] + + - fix errors in last trial release relating to Moose::Error::Default, + Moose::Util::throw_error (Upasana) + +2.1102 2013-10-20 (TRIAL RELEASE) + + [BUG FIXES] + + - die if a role to consume can't be found -- this restores behaviour as in + 2.1005 (doy) + - fix test to accomodate Devel::PartialDump possibly not being installed + (Upasana) + +2.1101 2013-10-20 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - Moose string exceptions have been replaced by Moose::Exception objects. See + Moose::Manual::Delta for details. + +2.1100 2013-09-07 (TRIAL RELEASE) + + [DEPRECATIONS] + + - Class::MOP::load_class, Class::MOP::is_class_loaded, and + Class::MOP::load_first_existing_class are now deprecated. See + Moose::Manual::Delta for details. + + - The non-arrayref forms of enum and duck_type have been deprecated. See + Moose::Manual::Delta for details. + + - Many deprecated features have now been removed: + - optimize_as for type constraints + - the "default is" and "default default" features for native delegations + - setting coerce => 1 on an attribute whose type constraint has no coercion + - the public version of Moose::Meta::Method::Destructor::initialize_body + + [ENHANCEMENTS] + + - Creating classes with Moose now always sets the appropriate entry in %INC, + even if it wasn't loaded from a file. This should make writing classes + inline easier, and will allow us to be more intelligent about figuring out + when classes are loaded in the future. See Moose::Manual::Delta for more + details. Note that this is slightly backwards-incompatible in some edge + cases. + + - Moose now uses Module::Runtime instead of Class::Load to load classes. This + means that there are no more issues with the weird heuristics that + Class::Load does to determine if a class was previously loaded (inheriting + from an empty package is now possible, for instance). See + Moose::Manual::Delta for more details. This is also slightly + backwards-incompatible in some edge cases. + +2.1005 2013-08-06 + + [ENHANCEMENTS] + + - add_method now accepts blessed subs (Graham Knop, PR#28) + + [BUG FIXES] + + - If a role consumed another role, we resolve method conflicts just like a + class consuming a role, but when metaclass compat tried to fix up + metaclass roles, we were putting all methods into one composite role and + allowing methods in the metaclass roles to conflict. Now we resolve them + as we should. (Jesse Luehrs, PR#27) + + - Some edge cases in tests with base.pm and non-existent module files are + handled more strictly (see also perl RT#118561) (Graham Knop, PR#25) + +2.1004 2013-07-26 + + [BUG FIXES] + + - 2.1003 was released with some bad metadata, which caused the prereq test + to fail. + +2.1003 2013-07-26 + + [OTHER] + + - Releasing 2.0901 as stable. + +2.0901 2013-06-21 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - The with_immutable() sub from Test::Moose now passes a boolean value to + the code block containing tests indicating whether or not the classes have + been made immutable. This can make for nicer test descriptions. (Dave + Rolsky) + + - You can now use Specio types instead of Moose builtins or + MooseX::Types. However, this support is still experimental (as is Specio), + so use it with care. (Dave Rolsky) + +2.0900 2013-05-26 (TRIAL RELEASE) + + [API CHANGES] + + - Fixed the Num builtin type to reject NaN, Inf, numbers with whitespace, + and other questionable strings. The MooseX::Types::LaxNum distro + implements the old behavior. RT#70539 (Upasana) + +2.0802 2013-05-07 + + [ENHANCEMENTS] + + - fix incompatibilities with Test::Builder 1.005+ (Karen Etheridge) + - Moose::Manual::Contributing updated to reflect the change of primary + repository from git.moose.perl.org to github.com + +2.0801 2013-03-28 + + [BUG FIXES] + + - properly apply traits at compile time (error introduced in 2.0800, + RT#77974). (doy) + +2.0800 2013-03-27 + + [ENHANCEMENTS] + + - The super() subroutine now carps if you pass it arguments. These arguments + are always ignored, but we used to ignore them silently. RT #77383. + + - Roles can now override methods from other roles they consume directly, + without needing to manually exclude them (just like classes can). (mst) + + [BUG FIXES] + + - Fix false positive when checking for circular references for modules that + use the "also" parameter with Moose::Exporter. Reported by Jon + Swartz. Fixed by Matthew Wickline. RT #63818. + + - Fix memory leak in type unions. (Karen Etheridge) RT#83929. + + - Fix application of traits at compile time. (doy) RT#77974. + +2.0604 2012-09-19 + + [BUG FIXES] + + - Fix nonsensical error message for inlined accessors of required attributes. + (doy) + + - Stop trying to localize a lexical (blead now throws an error for this). RT + #79257, perl #114628. (sprout) + + [OTHER] + + - Depend on a version of Carp new enough to have caller_info. RT #79367. + (pshangov) + +2.0603 2012-06-28 + + [BUG FIXES] + + - Fix test failure in blead. RT #78085. + +2.0602 2012-05-07 + + [BUG FIXES] + + - Ensure that the Moose::Exporter-generated init_meta returns the same value + that it did previously. This isn't really a bug, since the return value has + never been tested or documented, but since the generated init_meta is + nothing more than a compatibility shim at this point, there's no reason to + not make it as compatible as possible. Reported by Moritz Onken. (doy) + + [DOCUMENTATION] + + - The lazy_build attribute feature was removed from + Moose::Manual::BestPractices. + +2.0601 2012-05-01 + + [BUG FIXES] + + - Fix init_meta order when multiple also packages are specified (this matters + when one of them is being used to actually initalize the metaclass, + typically with also => 'Moose'). Reported by Randy Stauner. (doy) + +2.0600 2012-04-29 + + [OTHER] + + - Releasing 2.0502 as stable. + +2.0502 2012-04-25 (TRIAL RELEASE) + + [OTHER] + + - The Test::DependentModules test now covers a much wider range of downstream + dependents (all of them in fact, for some definition of "all"). This should + allow us to track inadvertent backwards compatibility breakages much more + effectively. (doy) + + - A few test tweaks to avoid spurious failures. (doy) + +2.0501 2012-04-03 (TRIAL RELEASE) + + [BUG FIXES] + + - Avoid syntax errors on pre-5.14. (doy) + +2.0500 2012-04-03 (TRIAL RELEASE) + + [NEW FEATURES] + + - Class::MOP::Class now has methods for introspecting and modifying the + overloaded operators for a class. (doy) + + [ENHANCEMENTS] + + - The cookbook recipes have all been renamed. Instead of numbered recipes + (Basics::Recipe1), we now have descriptive names + (Basics::Point_AttributesAndSubclassing). This makes it easier for us to + add and remove recipes in the future, and makes it a little easier to + converse about them, since the name gives us some clue of what they + contain. + + [BUG FIXES] + + - Re-declaring a class_type or role_type constraint that has already been + declared now just returns the original type constraint, rather than + replacing the original constraint and ergo losing any coercions that were + on the original constraint. Fixes RT #73289. (t0m) + + - Moose::Exporter now calls init_meta methods in the correct order, when + multiple levels of 'also' parameters are specified. Reported by Rocco + Caputo. (doy, perigrin) + + - Moose::Exporter no longer generates init_meta methods in order to apply + metaroles, since the metaclass itself isn't guaranteed to exist yet at that + point. Metaroles are now applied at the end of import, after all + user-defined init_meta methods have been called. Fixes RT #51561. (doy) + + - Fixed a memory leak. This occurred when creating an anonymous + class. Immutabilizing an anonymous class still leaks memory due to a bug in + Eval::Closure (which should hopefully be fixed soon). Based on code and bug + report from Carlos Lima. RT #74650. + + - Fix a segfault when adding a method to a class which was defined in a + package which was deleted. (doy) + +2.0403 2012-04-03 + + [OTHER] + + - No changes, reupload to fix indexing. + +2.0402 2012-02-04 + + [OTHER] + + - Minor documentation fixes. + + - Fix test failure on blead (test was unnecessarily strict). Reported by + Nicholas Clark. (doy) + +2.0401 2011-11-17 + + [BUG FIXES] + + - Attributes with weak_ref now weaken their associated slot when they are + initialized through a lazy default or builder. Reported by tome. (doy) + +2.0400 2011-11-15 + + [OTHER] + + - No changes from 2.0302 (other than a few minor documentation tweaks). + +2.0302 2011-11-02 (TRIAL RELEASE) + + [BUG FIXES] + + - Fix test failure on 5.8. (Dave Rolsky) + + - Make make_immutable return value consistent and document it to be true. + (mst) + +2.0301 2011-10-21 (TRIAL RELEASE) + + [BUG FIXES] + + - Fix compilation on 5.8. Reported by ether. (doy) + + - A custom error class caused a warning when the class that used it was made + immutable. Reported by Maroš Kollár. RT #71514. (Dave Rolsky) + + [ENHANCEMENTS] + + - The enum type will now allow single value enumerations. Previously, two or + more values were required. (rjbs) + +2.0300 2011-09-23 (TRIAL RELEASE) + + [DEPRECATIONS] + + - The optimize_as option for type constraints has been deprecated. Use the + inline_as option to provide inlining code instead. (Dave Rolsky) + + [API CHANGES] + + - Methods to introspect a class's methods will now return methods defined in + UNIVERSAL (isa, can, etc.). This also means that you can wrap these + methods with method modifiers. RT #69839. Reported by Vyacheslav + Matyukhin. (Dave Rolsky) + + - The ->parent and ->parents method for a union now return the nearest + common ancestor of that union's component types. See Moose::Manual::Delta + for more details. (Dave Rolsky) + + - The ->parents method used to return an arrayref for union types, and a + list of one or more types for all other types. Now they all return + lists. (Dave Rolsky) + + - The ->is_subtype_of and ->is_a_type_of methods have changed their behavior + for union types. Previously, they returned true if any of their member + types returned true for a given type. Now, all of the member types must + return true. RT #67731. (Dave Rolsky) + + [ENHANCEMENTS] + + - The Moose::Exporter module now has a "meta_lookup" option when creating an + importer. This allows you to specify an alternate method for determining + the metaclass of a caller. This is useful for modules like + MooseX::Role::Parameterized which generate new metaclasses on the + fly. (sartak) + + - Added a Moose::Meta::Method->is_stub method. (Dave Rolsky) + + [BUG FIXES] + + - A subtype of a union type did not return the right results when you called + ->is_subtype_of or ->is_a_type_of on it. This has been fixed. RT + #70322. (Dave Rolsky) + + - An attribute accessor or delegation method can overwrite a stub method and + this will no longer throw an error. Reported by Mark-Jason Dominus. RT + #69988. (Dave Rolsky) + + - The error generated by unfulfilled method requirements during role + composition now mentions how to work around imported methods not being + recognized. Reported by Michael Schwern. RT #60583. (doy) + + - class_type and role_type will now throw errors if you attempt to use them + to override existing types, just like type and subtype have always done. + (doy) + + - Implicitly creating class or role types by using them as the 'isa' or + 'does' parameter to attribute construction will now register the type. This + means that it cannot later be redefined as something else. (doy) + + - $class_type->is_subtype_of no longer returns true if passed the name of the + class that the class type represents when the class type wasn't registered. + (doy) + + - Removing anonymous metaclasses prematurely no longer prevents reaping of + the associated stash. (doy) + + [OTHER] + + - The Class::MOP::load_class and Class::MOP::is_class_loaded subroutines are + no longer documented, and will cause a deprecation warning in the + future. Moose now uses Class::Load to provide this functionality, and you + should as well. (Dave Rolsky) + +2.0205 2011-09-06 + + [NEW FEATURES] + + - The Array and Hash native traits now provide a "shallow_clone" method, + which will return a reference to a new container with the same contents as + the attribute's reference. + + [ENHANCEMENTS] + + - Specifying an invalid value in a hashref 'handles' value now throws a + sensible error. Reported by Mark-Jason Dominus. RT #69990. (Dave + Rolsky) + + [BUG FIXES] + + - When specifying an attribute trait, passing options for the trait besides + -alias or -excludes caused a warning. However, passing other options is + totally valid when using MooseX::Role::Parameterized. Fixes RT + #70419. (sartak) + + - Allow regexp objects in duck_type constraints (to bring this in line with + the Object constraint). + +2.0204 2011-08-25 + + [BUG FIXES] + + - Validating duck_type type constraint turned out to work only by accident, + and only when not running under the debugger. This has been fixed. + (Florian Ragwitz) + + [OTHER] + + - Loosen the dependency on ExtUtils::ParseXS. + +2.0203 2011-08-23 + + [BUG FIXES] + + - is_class_loaded now properly detects packages which have a version object + in their $VERSION. + + - Fix XS compilation under blead. + +2.0202 2011-07-26 + + [BUG FIXES] + + - Be more consistent about how type constraint messages are handled. + +2.0201 2011-07-22 + + [BUG FIXES] + + - Moose::Util::does_role shouldn't call ->does on things that don't inherit + from Moose::Object. + + - Make ->does initialize the metaclass, so that calling it as a class method + on a class which sets up inheritance via some method other than extends + works properly (this fixes an issue with MooseX::Types). + + - Make Dist::CheckConflicts a runtime requirement, so moose-outdated always + works. + +2.0200 2011-07-18 + + [OTHER] + + - No changes from 2.0105 (other than a few minor documentation tweaks). + +2.0105 2011-06-27 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - Moose::Util::does_role now respects overridden ->does methods. (doy) + +2.0104 2011-06-20 (TRIAL RELEASE) + + [OTHER] + + - Include changes from 2.0010. + +2.0103 2011-06-20 (TRIAL RELEASE) + + [DEPRECATIONS] + + - Several things that have been deprecated for a while have been removed. See + the 2.0000 section in Moose::Manual::Delta for details. + + [NEW FEATURES] + + - New Moose::Util::TypeConstraints::union function for creating union type + constraints without having to rely on the string type constraint parsing. + This also allows for creating unions of anonymous type constraints. + (kentnl) + + [OTHER] + + - Include changes from Moose 2.0009. + +2.0102 2011-06-18 (TRIAL RELEASE) + + [ENHANCEMENTS] + + - The native Array trait now has a 'first_index' method, which works just + like the version in List::MoreUtils. (Karen Etheridge) + + - Clean up some internal code to help out extensions. + + [OTHER] + + - Include changes from Moose 2.0008. + +2.0101 2011-06-06 (TRIAL RELEASE) + + [OTHER] + + - Various packaging issues. + +2.0100 2011-06-06 (TRIAL RELEASE) + + [DEPRECATIONS] + + - Using a hand-optimized type constraint is now deprecated. In keeping with + our release policy, this won't actually start warning until the 2.0200 + release. + + [NEW FEATURES] + + - Type constraints can now provide inlined versions, which should make + inlined code which uses type constraints (such as accessors) faster. This + replaces the existing hand-optimized constraint feature. (Dave Rolsky) + + [ENHANCEMENTS] + + - Remove a lot of cases where generated methods closed over meta objects. + Most simple cases should now only close over simple data types and + coderefs. This should make deparsing simpler. + +2.0010 2011-06-20 + + [BUG FIXES] + + - Fix regression in 2.0009 and 2.0103 when applying roles during init_meta in + an exporter that also re-exports Moose or Moose::Role. (t0m, ilmari) + +2.0009 2011-06-19 + + [BUG FIXES] + + - duck_type type constraints now report reasonable errors when given + something which isn't an instance of an object. (t0m) + + - Moose::Util::apply_all_roles now works even if the applicant is a non-Moose + class. (perigrin) + + - When an object is reblessed, triggers are called on attributes that are + set during the reblessing. (Karen Etheridge). + + [OTHER] + + - Better error message if Moose->init_meta is called with a 'metaclass' + option when that metaclass hasn't been loaded. (jasonmay) + +2.0008 2011-06-16 + + [BUG FIXES] + + - The 'accessor' native delegation for hashrefs now allows setting the value + to undef. (sugoik, doy) + + [ENHANCEMENTS] + + - Various generated methods have more useful context information. (doy) + +2.0007 2011-05-15 + + [BUG FIXES] + + - Make sure weak attributes remain weak when cloning. (doy, rafl) + +2.0006 2011-05-09 + + [BUG FIXES] + + - Revert the List::MoreUtils version bump, as it breaks backwards + compatibility. The dependency will be bumped with Moose 2.0200. + +2.0005 2011-05-09 + + [BUG FIXES] + + - Only sort the alias keys when determining caching. + +2.0004 2011-05-09 + + [BUG FIXES] + + - Bump the List::MoreUtils dep to avoid buggy behavior in old versions. + + - Sort the list of roles and the alias and excludes parameters when + determining caching, since their order doesn't matter. + +2.0003 2011-05-09 + + [BUG FIXES] + + - Applying multiple role objects (rather than role names) at once no longer + skips every other role. (rjbs) + + - Caching of anon classes now works more sanely in the presence of role + application parameters - alias and excludes options are taken into account, + and caching is disabled entirely if other parameters exist. Asking for + caching (instead of just not weakening) when parameters are given will + begin warning in Moose 2.0200. (doy, autarch) + +2.0002 2011-04-28 + + [ENHANCEMENTS] + + - Provide definition context information for constructors and destructors, so + that they will show up as something other than "generated method (unknown + origin)". Also, add the package that accessors are defined in to their + definition context. + + - Use Devel::PartialDump in type constraint error messages, if it is + installed. + + [BUG FIXES] + + - Stop hiding warnings produced by throwing errors in DEMOLISH methods. + + - The 'reset' native delegation for Counter attributes will now also respect + builders (previously, it only respected defaults). + +2.0001 2011-04-22 + + [ENHANCEMENTS] + + - Anonymous classes and roles now have a unified implementation in + Class::MOP::Package. This means that anonymous packages are now also + possible. (Shawn M Moore, doy) + + [BUG FIXES] + + - No longer call XSLoader from multiple places, as this causes issues on + older perls. (doy, ribasushi) + + - Moose::Meta::Role->create now accepts the 'roles' parameter, as it was + documented to. (Chris Weyl) + + - Depend on Eval::Closure 0.04, which fixes some issues in mod_perl + environments. (doy, mateu) + +2.0000 2011-04-11 + + [API CHANGES] + + - The RegexpRef type constraint now accepts regular expressions blessed into + other classes, such as those found in pluggable regexp engines. + Additionally the 'Object' constraint no longer rejects objects implemented + as a blessed regular expression. (David Leadbeater) + + [DOCUMENTATION] + + - The lazy_build attribute feature was mostly removed from the docs and is + no longer encouraged. + + [OTHER] + + - Moose::Manual::Support now explicitly states when major releases are + allowed to happen (January, April, July, or October). + +1.9906 2011-04-04 (TRIAL RELEASE) + + [OTHER] + + - Update conflicts list. + - Minor pod updates. + +1.9905 2011-03-28 (TRIAL RELEASE) + + [NEW FEATURES] + + - The Moose::Meta::Role::Attribute class now has an original_role method + which returns the role which first defined an attribute. See the docs for + details. (Dave Rolsky) + + - Moose::Util::MetaRole will make sure that the class to which you're + applying metaroles or base class roles can actually have them applied. If + not (it's not a Moose class, it has a non-Moose metaclass, etc.), then it + gives a useful error message. Previously, this would just end up dying in + the MetaRole code without a useful message. (Dave Rolsky) + + [BUG FIXES] + + - When a role had its own applied_attribute metaclass (usually from MetaRole + application), that metaclass would get lost when that role participated in + role composition. It was also lost if that role was consumed by some other + role. Both of these cases have been fixed. Attributes are always applied + with the applied_attribute metaclass of the role which originally defined + them. (Dave Rolsky) + +1.9904 2011-03-04 (TRIAL RELEASE) + + [BUG FIXES] + + - Reinitializing anonymous roles used to accidentally clear out the role's + stash in some circumstances. This is now fixed. (doy) + + - The Int type constraint now rejects integers with trailing newlines. + (Matthew Horsfall) + +1.9903 2011-02-28 (TRIAL RELEASE) + + [BUG FIXES] + + - Reverse the order that Moose::Exporter 'also' exports are dispatched. When + trying to re-export from a package that itself exported a modified set of + Moose sugar, you'd get the original Moose sugar instead of the overrides. + There are also now tests for this. (perigrin) + + - Don't initialize lazy attributes with defaults in the constructor (for + immutable classes). (mo) + + - When reinitializing meta objects for classes and roles, we failed to + preserve roles and role applications. This led to weird bugs. Many MooseX + modules end up reinitializing your class or role. (Dave Rolsky) + +1.9902 2011-01-03 (TRIAL RELEASE) + + [OTHER] + + - Fix generation of CCFLAGS. + + - Add a bit more Dist::Zilla functionality. + +1.9901 2011-01-03 (TRIAL RELEASE) + + [OTHER] + + - Fix some indexing issues. + + - Fix a few issues with the conflict checking stuff. + +1.9900 2011-01-01 (TRIAL RELEASE) + + [OTHER] + + - The entire Class::MOP distribution has been merged with Moose. In the + future, the Class::MOP code itself will be merged into Moose, and + eventually the Class::MOP namespace will disappear entirely. For the + current release, we have simply changed how Class::MOP is + distributed. (Dave Rolsky). + + - Switched to Dist::Zilla for development. However, we still have a minimal + Makefile.PL in the repository that can be used for development. (Dave + Rolsky) + + [API CHANGES] + + - Roles now have their own default attribute metaclass to use during + application to a class, rather than just using the class's + attribute_metaclass. This is also overridable via ::MetaRole, with the + applied_attribute key in the role_metaroles hashref (doy). + + - The internal code used to generate inlined methods (accessor, constructor, + etc.) has been massively rewritten. MooseX modules that do inlining will + almost certainly need to be updated as well. + + [ENHANCEMENTS] + + - We now load the roles needed for native delegations only as needed. This + speeds up the compilation time for Moose itself. (doy) + + +1.25 2011-04-01 + + [BUG FIXES] + + - Reinitializing anonymous roles used to accidentally clear out the role's + stash in some circumstances. This is now fixed. (doy) (backported from + 1.9904) + + +1.24 2011-02-22 + + [BUG FIXES] + + - Reverse the order that Moose::Exporter 'also' exports are dispatched. When + trying to re-export from a package that itself exported a modified set of + Moose sugar, you'd get the original Moose sugar instead of the overrides. + There are also now tests for this. (perigrin) (backported from 1.9903) + + +1.23 2011-02-13 + + [PACKAGING FIX] + + - The 1.22 release had a bad MANIFEST. This has been fixed. + + +1.22 2011-02-13 + + [BUG FIXES] + + - When reinitializing meta objects for classes and roles, we failed to + preserve roles and role applications. This led to weird bugs. Many MooseX + modules end up reinitializing your class or role. (Dave Rolsky) (backported + from 1.9903) + +1.21 2010-11-24 + + [ENHANCEMENTS] + + - The Support manual has been updated to reflect our new major/minor version + policy. (Chris Prather) + + - The Contributing manual has been updated to reflect workflow changes based + on this new support policy. (doy) + + [BUG FIXES] + + - The role attribute metaclass did not inherit from Class::MOP::Object, + which could cause errors when trying to resolve metaclass compatibility + issues. Reported by Daniel Ruoso. (doy) + + - The lazy_build feature was accidentally removed from all the docs. Now + it's listed in Moose.pm again. (Chris Prather) + +1.20 2010-11-19 + + [BUG FIXES] + + - When using native delegations, if an array or hash ref member failed a + type constraint check, Moose ended up erroring out with "Can't call method + "get_message" on unblessed reference" instead of generating a useful error + based on the failed type constraint. Reported by t0m. RT #63113. (Dave + Rolsky) + +1.19 2010-11-02 + + [BUG FIXES] + + - There was still one place in the code trying to load Test::Exception + instead of Test::Fatal. (Karen Etheridge) + + +1.18 2010-10-31 + + [ENHANCEMENTS] + + - Type constraint objects now have an assert_coerce method which will either + return a valid value or throw an error. (rjbs) + + - We now warn when an accessor for one attribute overwrites an accessor for + another attribute. RT #57510. (Dave Rolsky) + + [BUG FIXES] + + - The native Array and Hash delegation methods now coerce individual new + members if the _member type_ has a coercion. In other words, if the array + reference is defined as an ArrayRef[DateTime], and you've defined a + coercion from Int to DateTime, then pushing an integer via a delegation + method will coerce the integer to a DateTime object. Reported by Karen + Etheridge. RT #62351. (Dave Rolsky) + + - An attribute using native delegations did not always properly coerce and + type check a lazily set default value. (doy and Dave Rolsky) + + - Using a regexp to define delegations for a class which was not yet loaded + did not actually work, but did not explicitly fail. However, it caused an + error when the class was loaded later. Reported by Max Kanat-Alexander. RT + #60596. (Dave Rolsky) + + - Attempting to delegate to a class or role which is not yet loaded will now + throw an explicit error. (Dave Rolsky) + + - Attempting to set lazy_build in an inherited attribute was ignored. RT + #62057. (perigrin) + + [OTHER] + + - The Moose test suite now uses Test::Fatal instead of + Test::Exception. (rjbs) + +1.17 2010-10-19 + + [BUG FIXES] + + - Make native delegation inlining work with instance metaclasses where slot + access is an do {} block, like Kioku. This fixes the use of native + delegations together with Kioku. (Scott, doy) + +1.16 2010-10-18 + + [ENHANCEMENTS] + + - Almost every native delegation method which changes the attribute value + now has an explicitly documented return value. In general, this return + value matches what Perl would return for the same operation. (Dave Rolsky) + + - Lots of work on native delegation documentation, including documenting + what arguments each native delegation method allows or requires. (Dave + Rolsky) + + - Passing an odd number of args to ->new() now gives a more useful warning + than Perl's builtin warning. Suggested by Sir Robert Burbridge. (Dave + Rolsky) + + - Allow disabling stack traces by setting an environment variable. See + Moose::Error::Default for details. This feature is considered + experimental, and may change in a future release. (Marcus Ramberg) + + - The deprecation warning for using alias and excludes without a leading + dash now tells you the role being applied and what it was being applied + to. (mst). + + [BUG FIXES] + + - A number of native trait methods which expected strings as arguments did + not allow the empty string. This included Array->join, String->match, + String->replace, and String->substr. Reported by Whitney Jackson. RT + #61962. (Dave Rolsky) + + - 'no Moose' no longer inadvertently removes imports it didn't create + itself. RT #60013. (Florian Ragwitz, doy) + + - Roles now support passing an array reference of method names to method + modifier sugar functions. (doy) + + - Native traits no longer use optimized inlining routines if the instance + requests it (in particular, if inline_get_slot_value doesn't return + something that can be assigned to). This should fix issues with + KiokuDB::Class. (doy) + + - We now ignore all Class::MOP and Moose classes when determining what + package called a deprecated feature. This should make the deprecation + warnings saner, and make it possible to turn them off more easily. (Dave + Rolsky) + + - The deprecated "default is" warning no longer happens if the attribute has + any accessor method defined (accessor, reader, writer). Also, this warning + only happens when a method that was generated because of the "default is" + gets called, rather than when the attribute is defined. (Dave Rolsky) + + - The "default default" code for some native delegations no longer issues a + deprecation warning when the attribute is required or has a builder. (Dave + Rolsky) + + - Setting a "default default" caused a fatal error if you used the builder + or lazy_build options for the attribute. Reported by Kent Fredric. RT + #59613. (Dave Rolsky) + +1.15 2010-10-05 + + [API CHANGES] + + - Major changes to Native Traits, most of which make them act more like + "normal" attributes. This should be mostly compatible with existing code, + but see Moose::Manual::Delta for details. + + - A few native traits (String, Counter, Bool) provide default values of "is" + and "default" when you created an attribute. Allowing them to provide + these values is now deprecated. Supply the value yourself when creating + the attribute. + + - New option 'trait_aliases' for Moose::Exporter, which will allow you to + generate non-global aliases for your traits (and allow your users to + rename the aliases, etc). (doy) + + - 'use Moose' and 'use Moose::Role' now accept a '-meta_name' option, to + determine which name to install the 'meta' name under. Passing 'undef' + to this option will suppress generation of the meta method entirely. (doy) + + - Moose now warns if it overwrites an existing method named "meta" in your + class when you "use Moose". (doy) + + [ENHANCEMENTS] + + - Native Trait delegations are now all generated as inline code. This should + be much faster than the previous method of delegation. In the best case, + native trait methods will be very highly optimized. + + - Reinitializing a metaclass no longer removes the existing method and + attribute objects (it instead fixes them so they are correct for the + reinitialized metaclass). This should make the order of loading many + MooseX modules less of an issue. (doy) + + - The Moose::Manual docs have been revised and updated. (Dave Rolsky) + + [BUG FIXES] + + - If an attribute was weak, setting it to a non-ref value after the object + was constructed caused an error. Now we only call weaken when the new + value is a reference. + + - t/040_type_constraints/036_match_type_operator.t failed on 5.13.5+. Fixed + based on a patch from Andreas Koenig. + +1.14 2010-09-21 + + [BUG FIXES] + + - Work around what looks like a bug in List::MoreUtils::any. This bug caused + a weird error when defining the same union type twice, but only when using + MooseX::Types. Reported by Curtis Jewell. RT #61001. (Dave Rolsky) + +1.13 2010-09-13 + + [API CHANGES] + + - The deprecation warnings for alias and excludes are back, use -alias and + -excludes instead. (Dave Rolsky) + + [ENHANCEMENTS] + + - When composing one role into another and there is an attribute conflict, + the error message now includes the attribute name. Reported by Sam + Graham. RT #59985. (Dave Rolsky) + + - When a class is made immutable, the does_role method is overridden with a + much faster version that simply looks role names up in a hash. Code which + uses lots of role-based type constraints should be faster. (Dave Rolsky) + +1.12 2010-08-28 + + [BUG FIXES] + + - Fix the MANIFEST. Fixes RT #60831, reported by Alberto Simões. + +1.11 2010-08-27 + + [API CHANGES] + + - An attribute in a subclass can now override the value of "is". (doy) + + - The deprecation warnings for alias and excludes have been turned back off + for this release, to give other module authors a chance to tweak their + code. (Dave Rolsky) + + [BUG FIXES] + + - mro::get_linear_isa was being called as a function rather than a method, + which caused problems with Perl 5.8.x. (t0m) + + - Union types always created a type constraint, even if their constituent + constraints did not have any coercions. This bogus coercion always + returned undef, which meant that a union which included Undef as a member + always coerced bad values to undef. Reported by Eric Brine. RT + #58411. (Dave Rolsky) + + - Union types with coercions would always fall back to coercing the value to + undef (unintentionally). Now if all the coercions for a union type fail, + the value returned by the coercion is the original value that we attempted + to coerce. (Dave Rolsky). + +1.10 2010-08-22 + + [API CHANGES] + + - The long-deprecated alias and excludes options for role applications now + issue a deprecation warning. Use -alias and -excludes instead. (Dave + Rolsky) + + [BUG FIXES] + + - Inlined code no longer stringifies numeric attribute defaults. (vg, doy) + + - default => undef now works properly. (doy) + + - Enum type constraints now throw errors if their values are nonsensical. + (Sartak) + + [ENHANCEMENTS] + + - Optimizations that should help speed up compilation time (Dave Rolsky). + +1.09 2010-07-25 + + [API CHANGES] + + - You can no longer pass "coerce => 1" for an attribute unless its type + constraint has a coercion defined. Doing so will issue a deprecation + warning. (Dave Rolsky) + + - Previously, '+foo' only allowed a specific set of options to be + overridden, which made it impossible to change attribute options related + to extensions. Now we blacklist some options, and anything else is + allowed. (doy, Tuomas Jormola) + + - Most features which have been declared deprecated now issue a warning using + Moose::Deprecated. Warnings are issued once per calling package, not + repeatedly. See Moose::Deprecated for information on how you can shut + these warnings up entirely. Note that deprecated features will eventually + be removed, so shutting up the warnings may not be the best idea. (Dave + Rolsky) + + - Removed the long-deprecated Moose::Meta::Role->alias_method method. (Dave + Rolsky). + + [NEW FEATURES] + + - We no longer unimport strict and warnings when Moose, Moose::Role, or + Moose::Exporter are unimported. Doing this was broken if the user + explicitly loaded strict and warnings themself, and the results could be + generally surprising. We decided that it was best to err on the side of + safety and leave these on. Reported by David Wheeler. RT #58310. (Dave + Rolsky) + + - New with_traits helper function in Moose::Util. (doy) + + [BUG FIXES] + + - Accessors will no longer be inlined if the instance metaclass isn't + inlinable. (doy) + + - Use Perl 5.10's new recursive regex features, if possible, for the type + constraint parser. (doy, nothingmuch) + + [ENHANCEMENTS] + + - Attributes now warn if their accessors overwrite a locally defined + function (not just method). (doy) + + [OTHER] + + - Bump our required perl version to 5.8.3, since earlier versions fail tests + and aren't easily installable/testable. + +1.08 2010-06-15 + + [ENHANCEMENTS] + + - Refactored a small amount of Moose::Meta::Method::Constructor to allow it + to be overridden more easily (doy). + +1.07 2010-06-05 + + [BUG FIXES] + + - Fixed a minor metaclass compatibility fixing bug dealing with immutable + classes and non-class metaclass traits (doy, dougdude). + +1.06 2010-06-01 + + [NEW FEATURES] + + - Added '0+' overloading in Moose::Meta::TypeConstraint so that we can + more uniformly compare type constraints between 'classic' Moose type + constraints and MooseX::Types based type constraints. + +1.05 2010-05-20 + + [API CHANGES] + + - Packages and modules no longer have methods - this functionality was + moved back up into Moose::Meta::Class and Moose::Meta::Role individually + (through the Class::MOP::Mixin::HasMethods mixin) (doy). + + - BUILDALL is now called by Moose::Meta::Class::new_object, rather than by + Moose::Object::new. (doy) + + [NEW FEATURES] + + - strict and warnings are now unimported when Moose, Moose::Role, or + Moose::Exporter are unimported. (doy, Adam Kennedy) + + - Added a 'consumers' method to Moose::Meta::Role for finding all + classes/roles which consume the given role. (doy) + + [BUG FIXES] + + - Fix has '+attr' in Roles to explode immediately, rather than when the role + is applied to a class (t0m). + + - Fix type constraint validation messages to not include the string 'failed' + twice in the same sentence (Florian Ragwitz). + + - New type constraints will default to being unequal, rather than equal + (rjbs). + + - The tests no longer check for perl's behavior of clobbering $@, which has + been fixed in perl-5.13.1 (Florian Ragwitz). + + - Metaclass compatibility fixing has been completely rewritten, and should + be much more robust. (doy) + +1.04 2010-05-20 + + - This release was broken and has been deleted from CPAN shortly after its + upload. + +1.03 2010-05-06 + + [NEW FEATURES] + + - Allow specifying required versions when setting superclasses or applying + roles (Florian Ragwitz). + +1.02 2010-05-01 + + [BUG FIXES] + + - Stop the natatime method provided by the native Array trait from returning + an exhausted iterator when being called with a callback. (Florian Ragwitz) + + - Make Moose::Meta::TypeConstraint::Class correctly reject RegexpRefs. + (Florian Ragwitz) + + - Calling is_subtype_of on a Moose::Meta::TypeConstraint::Class with itself or + the class the TC represents as an argument incorrectly returned true. This + behavior is correct for is_type_of, not is_subtype_of. (Guillermo Roditi) + + - Use File::Temp for temp files created during tests. Previously, files were + written to the t/ dir, which could cause problems of the user running the + tests did not have write access to that directory.. (Chris Weyl, Ævar + Arnfjörð Bjarmason) + + - Pass role arguments along when applying roles to instances. (doy, lsm) + +1.01 2010-03-26 + + [NEW FEATURES] + + - The handles option now also accepts a role type constraint in addition to a + plain role name. (Florian Ragwitz) + + [OTHER] + + - Record the Sartak/doy debt properly in Changes (perigrin) + +1.00 2010-03-25 + + [BUG FIXES] + + - Moose::Meta::Attribute::Native::Trait::Code no longer creates reader + methods by default. (Florian Ragwitz) + + [DOCUMENTATION] + + - Improve various parts of the documentation and fix many typos. + (Dave Rolsky, Mateu Hunter, Graham Knop, Robin V, Jay Hannah, Jesse Luehrs) + + [OTHER] + + - Paid the $10 debt to doy from 0.80 2009-06-06 (Sartak) + +0.99 2010-03-08 + + [NEW FEATURES] + + - New method find_type_for in Moose::Meta::TypeConstraint::Union, for finding + which member of the union a given value validates for. (Cory Watson) + + [BUG FIXES] + + - DEMOLISH methods in mutable subclasses of immutable classes are now called + properly (Chia-liang Kao, Jesse Luehrs) + + [NEW DOCUMENTATION] + + - Added Moose::Manual::Support that defines the support, compatiblity, and + release policies for Moose. (Chris Prather) + +0.98 2010-02-10 + + [BUG FIXES] + + - An internals change in 0.97 broke role application to an instance in some + cases. The bug occurred when two different roles were applied to different + instances of the same class. (Rafael Kitover) + + +0.97 2010-02-09 + + [BUG FIXES] + + - Calling ->reinitialize on a cached anonymous class effectively uncached + the metaclass object, causing the metaclass to go out of scope + unexpectedly. This could easily happen at a distance by applying a + metarole to an anonymous class. (Dave Rolsky). + +0.96 2010-02-06 + + [NEW FEATURES] + + - ScalarRef is now a parameterized type. You can now specify a type + constraint for whatever the reference points to. (Closes RT#50857) + (Michael G. Schwern, Florian Ragwitz) + + [BUG FIXES] + + - ScalarRef now accepts references to other references. (Closes RT#50934) + (Michael G. Schwern) + +0.95 2010-02-04 + + [NEW FEATURES] + + - Moose::Meta::Attribute::Native::Trait::Code now provides execute_method as + a delegation option. This allows the code reference to be called as a + method on the object. (Florian Ragwitz) + + [ENHANCEMENTS] + + - Moose::Object::does no longer checks the entire inheritance tree, since + Moose::Meta::Class::does_role already does this. (doy) + + - Moose::Util::add_method_modifier (and subsequently the sugar functions + Moose::before, Moose::after, and Moose::around) can now accept arrayrefs, + with the same behavior as lists. Types other than arrayref and regexp + result in an error. (Dylan Hardison) + +0.94 2010-01-18 + + [API CHANGES] + + - Please see the changes listed for 0.93_01 and Moose::Manual::Delta. + + [ENHANCEMENTS] + + - Improved support for anonymous roles by changing various APIs to take + Moose::Meta::Role objects as well as role names. This included + + - Moose::Meta::Class->does_role + - Moose::Meta::Role->does_role + - Moose::Util::does_role + - Moose::Util::apply_all_roles + - Moose::Util::ensure_all_roles + - Moose::Util::search_class_by_role + + Requested by Shawn Moore. Addresses RT #51143 (and then some). (Dave Rolsky) + + [BUG FIXES] + + - Fix handling of non-alphanumeric attributes names like '@foo'. This should + work as long as the accessor method names are explicitly set to valid Perl + method names. Reported by Doug Treder. RT #53731. (Dave Rolsky) + + +0.93_03 2010-01-05 + + [BUG FIXES] + + - Portability fixes to our XS code so we compile with 5.8.8 and Visual + C++. Fixes RT #53391. Reported by Taro Nishino. (rafl) + + +0.93_02 2010-01-05 + + [BUG FIXES] + + - Depend on Class::MOP 0.97_01 so we can get useful results from CPAN + testers. (Dave Rolsky) + + +0.93_01 2010-01-04 + + [API CHANGES] + + See Moose::Manual::Delta for more details on backwards compatiblity issues. + + - Role attributes are now objects of the Moose::Meta::Role::Attribute + class. (Dave Rolsky). + + - There were major changes to how metaroles are applied. We now distinguish + between metaroles for classes vs those for roles. See the + Moose::Util::MetaRole docs for details. (Dave Rolsky) + + - The old MetaRole API has been deprecated, but will continue to + work. However, if you are applying an attribute metaclass role, this may + break because of the fact that roles now have an attribute metaclass + too. (Dave Rolsky) + + - Moose::Util::MetaRole::apply_metaclass_roles is now called + apply_metaroles. The old name is deprecated. (Dave Rolsky) + + - The unimport subs created by Moose::Exporter now clean up re-exported + functions like blessed and confess, unless the caller imported them from + somewhere else too. See Moose::Manua::Delta for backcompat details. (rafl) + + [ENHANCEMENTS AND BUG FIXES] + + - Changed the Str constraint to accept magic lvalue strings like one gets from + substr et al, again. (sorear) + + - Sped up the type constraint parsing regex. (Sam Vilain) + + - The Moose::Cookbook::Extending::Recipe2 recipe was broken. Fix suggested by + jrey. + + - Added Moose::Util::TypeConstraints exports when using oose.pm to allow + easier testing of TypeConstraints from the command line. (perigrin) + + - Added a with_immutable test function to Test::Moose, to run a block of tests + with and without certain classes being immutable. (doy) + + - We now use Module::Install extensions explicitly to avoid confusing errors + if they're not installed. We use Module::Install::AuthorRequires to stop + test extraction and general failures if you don't have the author side + dependencies installed. + + - Fixed a grammar error in Moose::Cookbook::Basics::Recipe4. rt.cpan.org + #51791. (Amir E. Aharoni) + + +0.93 2009-11-19 + - Moose::Object + - Calling $object->new() is no longer deprecated, and no longer + warns. (doy) + + - Moose::Meta::Role + - The get_attribute_map method is now deprecated. (Dave Rolsky) + + - Moose::Meta::Method::Delegation + - Preserve variable aliasing in @_ for delegated methods, so that + altering @_ affects the passed value. (doy) + + - Moose::Util::TypeConstraints + - Allow array refs for non-anonymous form of enum and duck_type, not + just anonymous. The non-arrayref forms may be removed in the + future. (doy) + - Changed Str constraint to not accept globs (*STDIN or *FOO). (chansen) + - Properly document Int being a subtype of Str. (doy) + + - Moose::Exporter + - Moose::Exporter using modules can now export their functions to the + main package. This applied to Moose and Moose::Role, among + others. (nothingmuch) + + - Moose::Meta::Attribute + - Don't remove attribute accessors we never installed, during + remove_accessors. (doy) + + - Moose::Meta::Attribute::Native::Trait::Array + - Don't bypass prototype checking when calling List::Util::first, to + avoid a segfault when it is called with a non-code argument. (doy) + + - Moose::Meta::Attribute::Native::Trait::Code + - Fix passing arguments to code execute helpers. (doy) + +0.92 2009-09-22 + - Moose::Util::TypeConstraints + - added the match_on_type operator (Stevan) + - added tests and docs for this (Stevan) + + - Moose::Meta::Class + - Metaclass compat fixing should already happen recursively, there's no + need to explicitly walk up the inheritance tree. (doy) + + - Moose::Meta::Attribute + - Add tests for set_raw_value and get_raw_value. (nothingmuch) + +0.91 2009-09-17 + - Moose::Object + - Don't import any functions, in order to avoid polluting our namespace + with things that can look like methods (blessed, try, etc) + (nothingmuch) + + - Moose::Meta::Method::Constructor + - The generated code needs to called Scalar::Util::blessed by its + fully-qualified name or else Perl can interpret the call to blessed as + an indirect method call. This broke Search::GIN, which in turn broke + KiokuDB. (nothingmuch) + +0.90 2009-09-15 + - Moose::Meta::Attribute::Native::Trait::Counter + - Moose::Meta::Attribute::Native::Trait::String + - For these two traits, an attribute which did not explicitly provide + methods to handles magically ended up delegating *all* the helper + methods. This has been removed. You must be explicit in your handles + declaration for all Native Traits. (Dave Rolsky) + + - Moose::Object + - DEMOLISHALL behavior has changed. If any DEMOLISH method dies, we make + sure to rethrow its error message. However, we also localize $@ before + this so that if all the DEMOLISH methods success, the value of $@ will + be preserved. (nothingmuch and Dave Rolsky) + - We now also localize $? during object destruction. (nothingmuch and + Dave Rolsky) + - The handling of DEMOLISH methods was broken for immutablized classes, + which were not receiving the value of + Devel::GlobalDestruction::in_global_destruction. + - These two fixes address some of RT #48271, reported by Zefram. + - This is all now documented in Moose::Manual::Construction. + - Calling $object->new() is now deprecated. A warning will be + issued. (perigrin) + + - Moose::Meta::Role + - Added more hooks to customize how roles are applied. The role + summation class, used to create composite roles, can now be changed + and/or have meta-roles applied to it. (rafl) + - The get_method_list method no longer explicitly excludes the "meta" + method. This was a hack that has been replaced by better hacks. (Dave + Rolsky) + + - Moose::Meta::Method::Delegation + - fixed delegated methods to make sure that any modifiers attached to + the accessor being delegated on will be called (Stevan) + - added tests for this (Stevan) + + - Moose::Meta::Class + - Moose no longer warns when a class that is being made immutable has + mutable ancestors. While in theory this is a good thing to warn about, + we found so many exceptions to this that doing this properly became + quite problematic. + +0.89_02 2009-09-10 + - Moose::Meta::Attribute::Native + - Fix Hash, which still had 'empty' instead of 'is_empty'. (hdp) + + - Moose::Meta::Attribute::Native::Trait::Array + - Added a number of functions from List::Util and List::MoreUtils, + including reduce, shuffle, uniq, and natatime. (doy) + + - Moose::Exporter + - This module will now generate an init_meta method for your exporting + class if you pass it options for + Moose::Util::MetaRole::apply_metaclass_roles or + apply_base_class_roles. This eliminates a lot of repetitive + boilerplate for typical MooseX modules. (doy). + - Documented the with_meta feature, which is a replacement for + with_caller. This feature was added by josh a while ago. + - The with_caller feature is now deprecated, but will not issue a + warning yet. (Dave Rolsky) + - If you try to wrap/export a subroutine which doesn't actually exist, + Moose::Exporter will warn you about this. (doy) + + - Moose::Meta::Role::Application::ToRole + - When a role aliased a method from another role, it was only getting + the new (aliased) name, not the original name. This differed from what + happens when a class aliases a role's methods. If you _only_ want the + aliased name, make sure to also exclue the original name. (Dave + Rolsky) + +0.89_01 2009-09-02 + - Moose::Meta::Attribute + - Added the currying syntax for delegation from AttributeHelpers to the + existing delegation API. (hdp) + + - Moose::Meta::Attribute::Native + - We have merged the functionality of MooseX::AttributeHelpers into the + Moose core with some API tweaks. You can continue to use + MooseX::AttributeHelpers, but it will not be maintained except + (perhaps) for critical bug fixes in the future. See + Moose::Manual::Delta for details. (hdp, jhannah, rbuels, Sartak, + perigrin, doy) + + - Moose::Error::Croak + - Moose::Error::Confess + - Clarify documentation on how to use different error-throwing + modules. (Curtis Jewell) + + - Moose + - Correct POD for builder to point to Recipe8, not 9. (gphat) + + - Moose::Exporter + - When a nonexistent sub name is passed to as_is, with_caller, or + with_meta, throw a warning and skip the exporting, rather than + installing a broken sub. (doy) + + - Moose::Meta::Class + - Moose now warns if you call C<make_immutable> for a class with mutable + ancestors. (doy) + +0.89 2009-08-13 + - Moose::Manual::Attributes + - Clarify "is", include discussion of "bare". (Sartak) + + - Moose::Meta::Role::Method::Conflicting + - Moose::Meta::Role::Application::ToClass + - For the first set of roles involved in a conflict, report all + unresolved method conflicts, not just the first method. Fixes #47210 + reported by Ovid. (Sartak) + + - Moose::Meta::TypeConstraint + - Add assert_valid method to use a TypeConstraint for assertion (rjbs) + + - Moose::Exporter + - Make "use Moose -metaclass => 'Foo'" do alias resolution, like -traits + does. (doy) + - Allow specifying role options (alias, excludes, MXRP stuff) in the + arrayref passed to "use Moose -traits" (doy) + + - Moose::Util + - Add functions meta_class_alias and meta_attribute_alias for creating + aliases for class and attribute metaclasses and metatraits. (doy) + + - Moose::Meta::Attribute + - Moose::Meta::Method::Accessor + - A trigger now receives the old value as a second argument, if the + attribute had one. (Dave Rolsky) + + - Moose::Meta::Method::Constructor + - Fix a bug with $obj->new when $obj has stringify overloading. + Reported by Andrew Suffield [rt.cpan.org #47882] (Sartak) + - However, we will probably deprecate $obj->new, so please don't start + using it for new code! + + - Moose::Meta::Role::Application + - Moose::Meta::Role::Application::RoleSummation + - Rename alias and excludes to -alias and -excludes (but keep the old + names for now, for backcompat) (doy) + +0.88 2009-07-24 + - Moose::Manual::Contributing + - Re-write the Moose::Manual::Contributing document to reflect + the new layout and methods of work for the Git repository. All + work now should be done in topic branches and reviewed by a + core committer before being applied to master. All releases + are done by a cabal member and merged from master to + stable. This plan was devised by Yuval, blame him. (perigrin) + + - Moose::Meta::Role + - Create metaclass attributes for the different role application + classes. (rafl) + + - Moose::Util::MetaRole + - Allow applying roles to a meta role's role application + classes. (rafl) + + - Moose::Meta::Attribute + - Add weak_ref to allowed options for "has '+foo'" (mst) + + - Moose::Meta::Method::Accessor + - No longer uses inline_slot_access in accessors, to support + non-lvalue-based meta instances. (sorear) + +0.87 2009-07-07 + - Moose::Meta::Method::Delegation + - Once again allow class names as well as objects for + delegation. This was changed in 0.86. + +0.86 2009-07-03 + - Moose::Meta::Class::Immutable::Trait + - Fixes to work with the latest Class::MOP. + + - Moose::Meta::Method::Delegation + - Delegation now dies with a more useful error message if the + attribute's accessor returns something defined but + unblessed. (hdp) + +0.85 2009-06-26 + - Moose::Meta::Attribute + - The warning for 'no associated methods' is now split out into + the _check_associated_methods method, so that extensions can + safely call 'after install_accessors => ...'. This fixes a + warning from MooseX::AttributeHelpers. (hdp) + +0.84 2009-06-26 + - Moose::Role + - has now sets definition_context for attributes defined in + roles. (doy) + + - Moose::Meta::Attribute + - When adding an attribute to a metaclass, if the attribute has + no associated methods, it will give a deprecation + warning. (hdp) + - Methods generated by delegation were not being added to + associated_methods. (hdp) + - Attribute accessors (reader, writer, accessor, predicate, + clearer) now warn if they overwrite an existing method. (doy) + - Attribute constructors now warn very noisily about unknown (or + misspelled) arguments + + - Moose::Util::TypeConstraints + - Deprecated the totally useless Role type name, which just + checked if $object->can('does'). Note that this is _not_ the + same as a type created by calling role_type('RoleName'). + + - Moose::Util::TypeConstraints + - Moose::Meta::TypeConstraint::DuckType + - Reify duck type from a regular subtype into an actual class + (Sartak) + - Document this because Sartak did all my work for me + (perigrin) + + - Moose::Meta::Attribute + - Allow Moose::Meta::TypeConstraint::DuckType in handles, since + it is just a list of methods (Sartak) + + - Moose::Meta::Role + - The get_*_method_modifiers methods would die if the role had + no modifiers of the given type (Robert Buels). + +0.83 2009-06-23 + - Moose::Meta::Class + - Fix _construct_instance not setting the special __MOP__ object + key in instances of anon classes. (doy) + +0.82 2009-06-21 + - Moose::Manual::Types + - Mention MooseX::Types early to avoid users falling down the + string parsing rathole (mst) + + - Moose::Manual::MooseX + - Add warnings about class-level extensions and mention considering + using plain objects instead + +0.81 2009-06-07 + - Bumped our Class::MOP prereq to the latest version (0.85), since + that's what we need. + +0.80 2009-06-06 + - Moose::Manual::FAQ + - Add FAQ about the coercion change from 0.76 because it came up + three times today (perigrin) + - Win doy $10 dollars because Sartak didn't think anybody + would document this fast enough (perigrin) + + - Moose::Meta::Method::Destructor + - Inline a DESTROY method even if there are no DEMOLISH methods + to prevent unnecessary introspection in + Moose::Object::DEMOLISHALL + + - Moose::* + - A role's required methods are now represented by + Moose::Meta::Role::Method::Required objects. Conflicts are now + represented by Moose::Meta::Role::Method::Conflicting + objects. The benefit for end-users in that unresolved + conflicts generate different, more instructive, errors, + resolving Ovid's #44895. (Sartak) + + - Moose::Role + - Improve the error message of "extends" as suggested by Adam + Kennedy and confound (Sartak) + - Link to Moose::Manual::Roles from Moose::Role as we now have + excellent documentation (Adam Kennedy) + + - Tests + - Update test suite for subname change in Class::MOP + (nothingmuch) + - Add TODO test for infinite recursion in Moose::Meta::Class + (groditi) + +0.79 2009-05-13 + - Tests + - More fixes for Win32 problems. Reported by Robert Krimen. + + - Moose::Object + - The DEMOLISHALL method could still blow up in some cases + during global destruction. This method has been made more + resilient in the face of global destruction's random garbage + collection order. + + - Moose::Exporter + - If you "also" a module that isn't loaded, the error message + now acknowledges that (Sartak) + + - Moose + - When your ->meta method does not return a Moose::Meta::Class, + the error message gave the wrong output (Sartak) + +0.78 2009-05-12 + - Moose::Cookbook::FAQ and Moose::Cookbook::WTF + - Merged these documents into what is now Moose::Manual::FAQ + + - Moose::Unsweetened + - Moved to Moose::Manual::Unsweetened + + - Moose::Cookbook::Basics::Recipes 9-12 + - Renamed to be 8-11, since recipe 8 did not exist + + - Moose::Exporter + - Make Moose::Exporter import strict and warnings into packages + that use it (doy) + + - Moose::Object + - Fix DEMOLISHALL sometimes not being able to find DEMOLISH + methods during global destruction (doy) + + - Moose::Meta::Class + - Moose::Meta::Role::Application::ToClass + - Track the Role::Application objects created during class-role + consumption (Sartak) + + - Moose::Meta::Class + - Fix metaclass incompatibility errors when extending a vanilla perl + class which isa Moose class with a metaclass role applied (t0m) + + - Moose::Meta::Role + - Add a role-combination hook, _role_for_combination, for the + benefit of MooseX::Role::Parameterized (Sartak) + + - Tests + - Some tests were failing on Win32 because they explicit checked + warning output for newlines. Reported by Nickolay Platonov. + +0.77 2009-05-02 + - Moose::Meta::Role + - Add explicit use of Devel::GlobalDestruction and Sub::Name + (perigrin) + + - Moose::Object + - Pass a boolean to DEMOLISHALL and DEMOLISH indicating whether + or not we are currently in global destruction (doy) + - Add explicit use of Devel::GlobalDestruction and Sub::Name + (perigrin) + + - Moose::Cookbook::FAQ + - Reworked much of the existing content to be more useful to + modern Moose hackers (Sartak) + + - Makefile.PL + - Depend on Class::MOP 0.83 instead of 0.82_01. + +0.76 2009-04-27 + - Moose::Meta::TypeConstraint + - Do not run coercions in coerce() if the value already passes the type + constraint (hdp) + + - Moose::Meta::TypeConstraint::Class + - In validation error messages, specifically say that the value is not + an instance of the class. This should alleviate some frustrating + forgot-to-load-my-type bugs. rt.cpan.org #44639 (Sartak) + + - Moose::Meta::Role::Application::ToClass + - Revert the class-overrides-role warning in favor of a solution outside + of the Moose core (Sartak) + + - Tests + - Make Test::Output optional again, since it's only used in a few files + (Sartak) + +0.75_01 2009-04-23 + - Moose::Meta::Role::Application::ToClass + - Moose now warns about each class overriding methods from roles it + consumes (Sartak) + + - Tests + - Warnings tests have standardized on Test::Output which is now an + unconditionally dependency (Sartak) + + - Moose::Meta::Class + - Changes to immutabilization to work with Class::MOP 0.82_01+. + +0.75 2009-04-20 + - Moose + - Moose::Meta::Class + - Move validation of not inheriting from roles from Moose::extends to + Moose::Meta::Class::superclasses (doy) + + - Moose::Util + - add ensure_all_roles() function to encapsulate the common "apply this + role unless the object already does it" pattern (hdp) + + - Moose::Exporter + - Users can now select a different metaclass with the "-metaclass" + option to import, for classes and roles (Sartak) + + - Moose::Meta::Role + - Make method_metaclass an attr so that it can accept a metarole + application. (jdv) + +0.74 2009-04-07 + - Moose::Meta::Role + - Moose::Meta::Method::Destructor + - Include stack traces in the deprecation warnings. + (Florian Ragwitz) + + - Moose::Meta::Class + - Removed the long-deprecated _apply_all_roles method. + + - Moose::Meta::TypeConstraint + - Removed the long-deprecated union method. + + +0.73_02 2009-04-06 + - More deprecations and renamings + - Moose::Meta::Method::Constructor + - initialize_body => _initialize_body (this is always called + when an object is constructed) + + - Moose::Object + - The DEMOLISHALL method could throw an exception during global + destruction, meaning that your class's DEMOLISH methods would + not be properly called. Reported by t0m. + + - Moose::Meta::Method::Destructor + - Destructor inlining was totally broken by the change to the + is_needed method in 0.72_01. Now there is a test for this + feature, and it works again. + + - Moose::Util + - Bold the word 'not' in the POD for find_meta (t0m) + +0.73_01 2009-04-05 + - Moose::* + - Call user_class->meta in fewer places, with the eventual goal + of allowing the user to rename or exclude ->meta + altogether. Instead uses Class::MOP::class_of. (Sartak) + + - Moose::Meta::Method::Accessor + - If an attribute had a lazy default, and that value did not + pass the attribute's type constraint, it did not get the + message from the type constraint, instead using a generic + message. Test provided by perigrin. + + - Moose::Util::TypeConstraints + - Add duck_type keyword. It's sugar over making sure an object + can() a list of methods. This is easier than jrockway's + suggestion to fork all of CPAN. (perigrin) + - add tests and documentation (perigrin) + + - Moose + - Document the fact that init_meta() returns the target class's + metaclass object. (hdp) + + - Moose::Cookbook::Extending::Recipe1 + - Moose::Cookbook::Extending::Recipe2 + - Moose::Cookbook::Extending::Recipe3 + - Moose::Cookbook::Extending::Recipe4 + - Make init_meta() examples explicitly return the metaclass and + point out this fact. (hdp) + + - Moose::Cookbook::Basics::Recipe12 + - A new recipe, creating a custom meta-method class. + + - Moose::Cookbook::Meta::Recipe6 + - A new recipe, creating a custom meta-method class. + + - Moose::Meta::Class + - Moose::Meta::Method::Constructor + - Attribute triggers no longer receive the meta-attribute object + as an argument in any circumstance. Previously, triggers + called during instance construction were passed the + meta-attribute, but triggers called by normal accessors were + not. Fixes RT#44429, reported by Mark Swayne. (hdp) + + - Moose::Manual::Attributes + - Remove references to triggers receving the meta-attribute object as an + argument. (hdp) + + - Moose::Cookbook::FAQ + - Remove recommendation for deprecated Moose::Policy and + Moose::Policy::FollowPBP; recommend MooseX::FollowPBP + instead. (hdp) + + - Many methods have been renamed with a leading underscore, and a + few have been deprecated entirely. The methods with a leading + underscore are consider "internals only". People writing + subclasses or extensions to Moose should feel free to override + them, but they are not for "public" use. + + - Moose::Meta::Class + - check_metaclass_compatibility => _check_metaclass_compatibility + + - Moose::Meta::Method::Accessor + - initialize_body => _initialize_body (this is always called + when an object is constructed) + - /(generate_.*_method(?:_inline)?)/ => '_' . $1 + + - Moose::Meta::Method::Constructor + - initialize_body => _initialize_body (this is always called + when an object is constructed) + - /(generate_constructor_method(?:_inline)?)/ => '_' . $1 + - attributes => _attributes (now inherited from parent) + - meta_instance => _meta_instance (now inherited from parent) + + - Moose::Meta::Role + - alias_method is deprecated. Use add_method + +0.73 2009-03-27 + - No changes from 0.72_01. + +0.72_01 2009-03-26 + - Everything + - Almost every module has complete API documentation. A few + methods (and even whole classes) have been intentionally + excluded pending some rethinking of their APIs. + + - Moose::Util::TypeConstraints + - Calling subtype with a name as the only argument is now an + exception. If you want an anonymous subtype do: + + my $subtype = subtype as 'Foo'; + + - Moose::Cookbook::Meta::Recipe7 + - A new recipe, creating a custom meta-instance class. + + - Moose::Cookbook::Basics::Recipe5 + - Fix various typos and mistakes. Includes a patch from Radu + Greab. + + - Moose::Cookbook::Basics::Recipe9 + - Link to this recipe from Moose.pm's builder blurb + + - Moose::Exporter + - When wrapping a function with a prototype, Moose::Exporter now + makes sure the wrapped function still has the same + prototype. (Daisuke Maki) + + - Moose::Meta::Attribute + - Allow a subclass to set lazy_build for an inherited + attribute. (hdp) + + - Makefile.PL + - Explicitly depend on Data::OptList. We already had this dependency + via Sub::Exporter, but since we're using it directly we're + better off with it listed. (Sartak) + + - Moose::Meta::Method::Constructor + - Make it easier to subclass the inlining behaviour. (Ash + Berlin) + + - Moose::Manual::Delta + - Details significant changes in the history of Moose, along + with recommended workarounds. + + - Moose::Manual::Contributing + - Contributor's guide to Moose. + + - Moose::Meta::Method::Constructor + - The long-deprecated intialize_body method has been removed + (yes, spelled like that). + + - Moose::Meta::Method::Destructor + - This is_needed method is now always a class method. + + - Moose::Meta::Class + - Changes to the internals of how make_immutable works to match + changes in latest Class::MOP. + +0.72 2009-02-23 + - Moose::Object + - Moose::Meta::Method::Constructor + - A mutable class accepted Foo->new(undef) without complaint, + while an immutable class would blow up with an unhelpful + error. Now, in both cases we throw a helpful error + instead. Reported by doy. + +0.71_01 2009-02-22 + - Moose::Cookbook + - Hopefully fixed some POD errors in a few recipes that caused + them to display weird on search.cpan.org. + + - Moose::Util::TypeConstraints + - Calling type or subtype without the sugar helpers (as, where, + message) is now deprecated. + - The subtype function tried hard to guess what you meant, but + often got it wrong. For example: + + my $subtype = subtype as 'ArrayRef[Object]'; + + This caused an error in the past, but now works as you'd + expect. + + - Everywhere + - Make sure Moose.pm is loaded before calling + Moose->throw_error. This wasn't normally an issue, but could + bite you in weird cases. + +0.71 2009-02-19 + - Moose::Cookbook::Basics::Recipe11 + - A new recipe which demonstrates the use of BUILDARGS and + BUILD. (Dave Rolsky) + + - Moose::Cookbook::Roles::Recipe3 + - A new recipe, applying a role to an object instance. (Dave + Rolsky) + + - Moose::Exporter + - Allow overriding specific keywords from "also" packages. (doy) + + - Tests + - Replace hardcoded cookbook tests with Test::Inline to ensure + the tests match the actual code in the recipes. (Dave Rolsky) + + - Moose::Cookbook + - Working on the above turned up a number of little bugs in the + recipe code. (Dave Rolsky) + + - Moose::Util::TypeConstraints::Optimized + - Just use Class::MOP for the optimized ClassName check. (Dave + Rolsky) + +0.70 2009-02-14 + - Moose::Util::TypeConstraints + - Added the RoleName type (stevan) + - added tests for this (stevan) + + - Moose::Cookbook::Basics::Recipe3 + - Updated the before qw[left right] sub to be a little more + defensive about what it accepts (stevan) + - added more tests to t/000_recipies/basics/003_binary_tree.t + (stevan) + + - Moose::Object + - We now always call DEMOLISHALL, even if a class does not + define DEMOLISH. This makes sure that method modifiers on + DEMOLISHALL work as expected. (doy) + - added tests for this (EvanCarroll) + + - Moose::Util::MetaRole + - Accept roles for the wrapped_method_metaclass (rafl) + - added tests for this (rafl) + + - Moose::Meta::Attribute + - We no longer pass the meta-attribute object as a final + argument to triggers. This actually changed for inlined code a + while back, but the non-inlined version and the docs were + still out of date. + + - Tests + - Some tests tried to use Test::Warn 0.10, which had bugs. Now + they require 0.11. (Dave Rolsky) + + - Documentation + - Lots of small changes to the manual, cookbook, and + elsewhere. These were based on feedback from various + users, too many to list here. (Dave Rolsky) + +0.69 2009-02-12 + - Moose + - Make some keyword errors use throw_error instead of croak + since Moose::Exporter wraps keywords now (Sartak) + + - Moose::Cookbook::* + - Revised every recipe for style and clarity. Also moved some + documentation out of cookbook recipes and into Moose::Manual + pages. This work was funded as part of the Moose docs grant + from TPF. (Dave Rolsky) + + - Moose::Meta::Method::Delegation + - If the attribute doing the delegation was not populated, the + error message did not specify the attribute name + properly. (doy) + +0.68 2009-02-04 + - POD + - Many spelling, typo, and formatting fixes by daxim. + + - Moose::Manual::Attributes + - The NAME section in the POD used "Attribute" so search.cpan + didn't resolve links from other documents properly. + + - Moose::Meta::Method::Overriden + - Now properly spelled as Overridden. Thanks to daxim for + noticing this. + +0.67 2009-02-03 + - Moose::Manual::* + - Lots of little typo fixes and a few clarifications. Several + pages didn't have proper titles, and so weren't actually + visible on search.cpan.org. Thanks to hanekomu for a variety + of fixes and formatting improvements. + +0.66 2009-02-03 + - Moose::Manual + - This is a brand new, extensive manual for Moose. This aims to + provide a complete introduction to all of Moose's + features. This work was funded as part of the Moose docs grant + from TPF. (Dave Rolsky) + + - Moose::Meta::Attribute + - Added a delegation_metaclass method to replace a hard-coded + use of Moose::Meta::Method::Delegation. (Dave Rolsky) + + - Moose::Util::TypeConstraints + - If you created a subtype and passed a parent that Moose didn't + know about, it simply ignored the parent. Now it automatically + creates the parent as a class type. This may not be what you + want, but is less broken than before. (Dave Rolsky) + + - Moose::Util::TypeConstraints + - This module tried throw errors by calling Moose->throw_error, + but it did not ensure that Moose was loaded first. This could + cause very unhelpful errors when it tried to throw an error + before Moose was loaded. (Dave Rolsky) + + - Moose::Util::TypeConstraints + - You could declare a name with subtype such as "Foo!Bar" that + would be allowed, but if you used it in a parameterized type + such as "ArrayRef[Foo!Bar]" it wouldn't work. We now do some + vetting on names created via the sugar functions, so that they + can only contain alphanumerics, ":", and ".". (Dave Rolsky) + +0.65 2009-01-22 + - Moose and Moose::Meta::Method::Overridden + - If an overridden method called super(), and then the + superclass's method (not overridden) _also_ called super(), + Moose went into an endless recursion loop. Test provided by + Chris Prather. (Dave Rolsky) + + - Moose::Meta::TypeConstraint + - All methods are now documented. (gphat) + + - t/100_bugs/011_DEMOLISH_eats_exceptions.t + - Fixed some bogus failures that occurred because we tried to + validate filesystem paths in a very ad-hoc and + not-quite-correct way. (Dave Rolsky) + + - Moose::Util::TypeConstraints + - Added maybe_type to exports. See docs for details. (rjbs) + + - Moose + - Added Moose::Util::TypeConstraints to the SEE ALSO + section. (pjf) + + - Moose::Role + - Methods created via an attribute can now fulfill a "requires" + declaration for a role. (nothingmuch) + + - Moose::Meta::Method::* + - Stack traces from inlined code will now report its line and + file as being in your class, as opposed to in Moose + guts. (nothingmuch). + +0.64 2008-12-31 + - Moose::Meta::Method::Accessor + - Always inline predicate and clearer methods (Sartak) + + - Moose::Meta::Attribute + - Support for parameterized traits (Sartak) + - verify_against_type_constraint method to avoid duplication + and enhance extensibility (Sartak) + + - Moose::Meta::Class + - Tests (but no support yet) for parameterized traits (Sartak) + + - Moose + - Require Class::MOP 0.75+, which has the side effect of making + sure we work on Win32. (Dave Rolsky) + +0.63 2008-12-08 + - Moose::Unsweetened + - Some small grammar tweaks and bug fixes in non-Moose example + code. (Dave Rolsky) + +0.62_02 2008-12-05 + - Moose::Meta::Role::Application::ToClass + - When a class does not provide all of a role's required + methods, the error thrown now mentions all of the missing + methods, as opposed to just the first one found. Requested by + Curtis Poe (RT #41119). (Dave Rolsky) + + - Moose::Meta::Method::Constructor + - Moose will no longer inline a constructor for your class + unless it inherits its constructor from Moose::Object, and + will warn when it doesn't inline. If you want to force + inlining anyway, pass "replace_constructor => 1" to + make_immutable. Addresses RT #40968, reported by Jon + Swartz. (Dave Rolsky) + - The quoting of default values could be broken if the default + contained a single quote ('). Now we use quotemeta to escape + anything potentially dangerous in the defaults. (Dave Rolsky) + +0.62_01 2008-12-03 + - Moose::Object + - use the method->execute API for BUILDALL + and DEMOLISHALL (Sartak) + + - Moose::Util::TypeConstraints + - We now make all the type constraint meta classes immutable + before creating the default types provided by Moose. This + should make loading Moose a little faster. (Dave Rolsky) + +0.62 2008-11-26 + - Moose::Meta::Role::Application::ToClass + Moose::Meta::Role::Application::ToRole + - fixed issues where excluding and aliasing the + same methods for a single role did not work + right (worked just fine with multiple + roles) (stevan) + - added test for this (stevan) + + - Moose::Meta::Role::Application::RoleSummation + - fixed the error message when trying to compose + a role with a role it excludes (Sartak) + + - Moose::Exporter + - Catch another case where recursion caused the value + of $CALLER to be stamped on (t0m) + - added test for this (t0m) + + - Moose + - Remove the make_immutable keyword, which has been + deprecated since April. It breaks metaclasses that + use Moose without no Moose (Sartak) + + - Moose::Meta::Attribute + - Removing an attribute from a class now also removes delegation + (handles) methods installed for that attribute (t0m) + - added test for this (t0m) + + - Moose::Meta::Method::Constructor + - An attribute with a default that looked like a number (but was + really a string) would accidentally be treated as a number + when the constructor was made immutable (perigrin) + - added test for this (perigrin) + + - Moose::Meta::Role + - create method for constructing a role + dynamically (Sartak) + - added test for this (Sartak) + - anonymous roles! (Sartak) + - added test for this (Sartak) + + - Moose::Role + - more consistent error messages (Sartak) + + - Moose::Cookbook::Roles::Recipe1 + - attempt to explain why a role that just requires + methods is useful (Sartak) + +0.61 2008-11-07 + - Moose::Meta::Attribute + - When passing a role to handles, it will be loaded if necessary + (perigrin) + + - Moose::Meta::Class + - Method objects returned by get_method (and other methods) + Could end up being returned without an associated_metaclass + attribute. Removing get_method_map, which is provided by + Class::MOP::Class, fixed this. The Moose version did nothing + different from its parent except introduce a bug. (Dave Rolsky) + - added tests for this (jdv79) + + - Various + - Added a $VERSION to all .pm files which didn't have one. Fixes + RT #40049, reported by Adam Kennedy. (Dave Rolsky) + + - Moose::Cookbook::Basics::Recipe4 + - Moose::Cookbook::Basics::Recipe6 + - These files had spaces on the first line of the SYNOPSIS, as + opposed to a totally empty line. According to RT #40432, this + confuses POD parsers. (Dave Rolsky) + +0.60 2008-10-24 + - Moose::Exporter + - Passing "-traits" when loading Moose caused the Moose.pm + exports to be broken. Reported by t0m. (Dave Rolsky) + - Tests for this bug. (t0m) + + - Moose::Util + - Change resolve_metaclass alias to use the new + load_first_existing_class function. This makes it a lot + simpler, and also around 5 times faster. (t0m) + - Add caching to resolve_metaclass_alias, which gives an order + of magnitude speedup to things which repeatedly call the + Moose::Meta::Attribute->does method, notably MooseX::Storage + (t0m) + + - Moose::Util::TypeConstraint + - Put back the changes for parameterized constraints that + shouldn't have been removed in 0.59. We still cannot parse + them, but MooseX modules can create them in some other + way. See the 0.58 changes for more details. (jnapiorkowski) + - Changed the way subtypes are created so that the job is + delegated to a type constraint parent. This clears up some + hardcoded checking and should allow correct subtypes of + Moose::Meta::Type::Constraint. Don't rely on this new API too + much (create_child_type) because it may go away in the + future. (jnapiorkowski) + + - Moose::Meta::TypeConstraint::Union + - Type constraint names are sorted as strings, not numbers. + (jnapiorkowski) + + - Moose::Meta::TypeConstraint::Parameterizable + - New parameterize method. This can be used as a factory method + to make a new type constraint with a given parameterized + type. (jnapiorkowski) + - added tests (jnapiorkowski) + +0.59 2008-10-14 + - Moose + - Add abridged documentation for builder/default/initializer/ + predicate, and link to more details sections in + Class::MOP::Attribute. (t0m) + + - Moose::Util::TypeConstraints + - removed prototypes from all but the &-based stuff (mst) + + - Moose::Util::TypeConstraints + - Creating a anonymous subtype with both a constraint and a + message failed with a very unhelpful error, but should just + work. Reported by t0m. (Dave Rolsky) + + - Tests + - Some tests that used Test::Warn if it was available failed + with older versions of Test::Warn. Reported by Fayland. (Dave + Rolsky) + - Test firing behavior of triggers in relation to builder/default/ + lazy_build. (t0m) + - Test behavior of equals/is_a_type_of/is_a_subtype_of for all + kinds of supported type. (t0m) + + - Moose::Meta::Class + - In create(), do not pass "roles" option to the superclass + - added related test that creates an anon metaclass with + a required attribute + + - Moose::Meta::TypeConstraint::Class + - Moose::Meta::TypeConstraint::Role + - Unify behavior of equals/is_a_type_of/is_a_subtype_of with + other types (as per change in 0.55_02). (t0m) + + - Moose::Meta::TypeConstraint::Registry + - Fix warning when dealing with unknown type names (t0m) + + - Moose::Util::TypeConstraints + - Reverted changes from 0.58 related to handle parameterized + types. This caused random failures on BSD and Win32 systems, + apparently related to the regex engine. This means that Moose + can no longer parse structured type constraints like + ArrayRef[Int,Int] or HashRef[name=>Str]. This will be + supported in a slightly different way via MooseX::Types some + time in the future. (Dave Rolsky) + +0.58 2008-09-20 + !! This release has an incompatible change regarding !! + !! how roles add methods to a class !! + + - Roles and role application + ! Roles now add methods by calling add_method, not + alias_method. They make sure to always provide a method + object, which will be cloned internally. This means that it is + now possible to track the source of a method provided by a + role, and even follow its history through intermediate roles. + + This means that methods added by a role now show up when + looking at a class's method list/map. (Dave Rolsky) + + - Makefile.PL + - From this release on, we'll try to maintain a list of + conflicting modules, and warn you if you have one + installed. For example, this release conflicts with ... + - MooseX::Singleton <= 0.11 + - MooseX::Params::Validate <= 0.05 + - Fey::ORM <= 0.10 + + In general, we try to not break backwards compatibility for + most Moose users, but MooseX modules and other code which + extends Moose's metaclasses is often affected by very small + changes in the Moose internals. + + - Moose::Meta::Method::Delegation + - Moose::Meta::Attribute + - Delegation methods now have their own method class. (Dave + Rolsky) + + - Moose::Meta::TypeConstraint::Parameterizable + - Added a new method 'parameterize' which is basically a factory + for the containing constraint. This makes it easier to create + new types of parameterized constraints. (jnapiorkowski) + + - Moose::Meta::TypeConstraint::Union + - Changed the way Union types canonicalize their names to follow + the normalized TC naming rules, which means we strip all + whitespace. (jnapiorkowski) + + - Moose::Util::TypeConstraints + - Parameter and Union args are now sorted, this makes Int|Str + the same constraint as Str|Int. (jnapiorkowski) + - Changes to the way Union types are parsed to more correctly + stringify their names. (jnapiorkowski) + - When creating a parameterized type, we now use the new + parameterize method. (jnapiorkowski) + - Incoming type constraint strings are now normalized to remove + all whitespace differences. (jnapiorkowski) + - Changed the way we parse type constraint strings so that we now + match TC[Int,Int,...] and TC[name=>Str] as parameterized type + constraints. This lays the foundation for more flexible type + constraint implementations. + + - Tests and docs for all the above. (jnapiorkowski) + + - Moose::Exporter + - Moose + - Moose::Exporter will no longer remove a subroutine that the + exporting package re-exports. Moose re-exports the + Carp::confess function, among others. The reasoning is that we + cannot know whether you have also explicitly imported those + functions for your own use, so we err on the safe side and + always keep them. (Dave Rolsky) + - added tests for this (rafl) + + - Moose::Meta::Class + - Changes to how we fix metaclass compatibility that are much + too complicated to go into. The summary is that Moose is much + less likely to complain about metaclass incompatibility + now. In particular, if two metaclasses differ because + Moose::Util::MetaRole was used on the two corresponding + classes, then the difference in roles is reconciled for the + subclass's metaclass. (Dave Rolsky) + - Squashed an warning in _process_attribute (thepler) + + - Moose::Meta::Role + - throw exceptions (sooner) for invalid attribute names (thepler) + - added tests for this (thepler) + + - Moose::Util::MetaRole + - If you explicitly set a constructor or destructor class for a + metaclass object, and then applied roles to the metaclass, + that explicitly set class would be lost and replaced with the + default. + + - Moose::Meta::Class + - Moose::Meta::Attribute + - Moose::Meta::Method + - Moose + - Moose::Object + - Moose::Error::Default + - Moose::Error::Croak + - Moose::Error::Confess + - All instances of confess() changed to use overridable + C<throw_error> method. This method ultimately calls a class + constructor, and you can change the class being called. In + addition, errors now pass more information than just a string. + The default C<error_class> behaves like C<Carp::confess>, so + the behavior is not visibly different for end users. + +0.57 2008-09-03 + - 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 2008-09-01 + 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 2008-08-30 + - 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 2008-08-29 + - No changes from 0.55_02 except increasing the Class::MOP + dependency to 0.64_07. + +0.55_02 2008-08-29 + - 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 2008-08-20 + + !! 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 2008-08-03 + - 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 2008-07-03 + ... 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 2008-07-03 + - 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 2008-07-03 + - 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 2008-06-26 + - Moose::Role + - add unimport so "no Moose::Role" actually does + something (sartak) + + - Moose::Meta::Role::Application::ToRole + - when RoleA did RoleB, and RoleA aliased a method from RoleB in + order to provide its own implementation, that method still got + added to the list of required methods for consumers of + RoleB. Now an aliased method is only added to the list of + required methods if the role doing the aliasing does not + provide its own implementation. See Recipe 11 for an example + of all this. (Dave Rolsky) + - added tests for this + + - Moose::Meta::Method::Constructor + - when a single argument that wasn't a hashref was provided to + an immutabilized constructor, the error message was very + unhelpful, as opposed to the non-immutable error. Reported by + dew. (Dave Rolsky) + - added test for this (Dave Rolsky) + + - 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 2008-06-12 + - Fixed a version number issue by bumping all modules + to 0.50. + +0.49 2008-06-12 + !! This version now approx. 20-25% !! + !! faster with new Class::MOP 0.59 !! + + - Moose::Meta::Attribute + - fixed how the is => (ro|rw) works with + custom defined reader, writer and accessor + options. + - added docs for this (TODO). + - added tests for this (Thanks to Penfold) + - added the custom attribute alias for regular + Moose attributes which is "Moose" + - fix builder and default both being used + (groditi) + + - Moose + Moose::Meta::Class + Moose::Meta::Attribute + Moose::Meta::Role + Moose::Meta::Role::Composite + Moose::Util::TypeConstraints + - switched usage of reftype to ref because + it is much faster + + - Moose::Meta::Role + - changing add_package_symbol to use the new + HASH ref form + + - Moose::Object + - fixed how DEMOLISHALL is called so that it + can be overrided in subclasses (thanks to Sartak) + - added test for this (thanks to Sartak) + + - Moose::Util::TypeConstraints + - move the ClassName type check code to + Class::MOP::is_class_loaded (thanks to Sartak) + + - Moose::Cookbook::Recipe11 + - add tests for this (thanks to tokuhirom) + +0.48 2008-05-29 + (early morning release engineering)-- + + - fixing the version in Moose::Meta::Method::Destructor + which was causing the indexer to choke + +0.47 2008-05-29 + (late night release engineering)-- + + - fixing the version is META.yml, no functional + changes in this release + +0.46 2008-05-28 + !! This version now approx. 20-25% !! + !! faster with new Class::MOP 0.57 !! + + - Moose::Meta::Class + - some optimizations of the &initialize method + since it is called so often by &meta + + - Moose::Meta::Class + Moose::Meta::Role + - now use the get_all_package_symbols from the + updated Class::MOP, test suite is now 10 seconds + faster + + - Moose::Meta::Method::Destructor + - is_needed can now also be called as a class + method for immutablization to check if the + destructor object even needs to be created + at all + + - Moose::Meta::Method::Destructor + Moose::Meta::Method::Constructor + - added more descriptive error message to help + keep people from wasting time tracking an error + that is easily fixed by upgrading. + +0.45 2008-05-24 + - Moose + - Because of work in Class::MOP 0.57, all + XS based functionality is now optional + and a Pure Perl version is supplied + - the CLASS_MOP_NO_XS environment variable + can now be used to force non-XS versions + to always be used + - several of the packages have been tweaked + to take care of this, mostly we added + support for the package_name and name + variables in all the Method metaclasses + - before/around/after method modifiers now + support regexp matching of names + (thanks to Takatoshi Kitano) + - tests added for this + - NOTE: this only works for classes, it + is currently not supported in roles, + but, ... patches welcome + - All usage of Carp::confess have been replaced + by Carp::croak in the "keyword" functions since + the stack trace is usually not helpful + + - Moose::Role + - All usage of Carp::confess have been replaced + by Carp::croak in the "keyword" functions since + the stack trace is usually not helpful + - The 'has' keyword for roles now accepts the + same array ref form that Moose.pm does + (has [qw/foo bar/] => (is => 'rw', ...)) + - added test for this + + - Moose::Meta::Attribute + - trigger on a ro-attribute is no longer an + error, as it's useful to trigger off of the + constructor + + - Moose::Meta::Class + - added same 'add_package_symbol' fix as in + Class::MOP 0.57 + + - Moose::Util + - does_role now handles non-Moose classes + more gracefully + - added tests for this + - added the 'add_method_modifier' function + (thanks to Takatoshi Kitano) + + - Moose::Util::TypeConstraints + - subtypes of parameterizable types now are + themselves parameterizable types + + - Moose::Meta::Method::Constructor + - fixed bug where trigger was not being + called by the inlined immutable + constructors + - added test for this (thanks to Caelum) + + - Moose::Meta::Role::Application::ToInstance + - now uses the metaclass of the instance + (if possible) to create the anon-class + (thanks Jonathan Rockway) + + - Moose::Cookbook::Recipe22 + - added the meta-attribute trait recipe + (thanks to Sartak) + + - t/ + - fixed hash-ordering test bug that was + causing occasional cpantester failures + - renamed the t/000_recipe/*.t tests to be + more descriptive (thanks to Sartak) + +0.44 2008-05-10 + - Moose + - made make_immutable warning cluck to + show where the error is (thanks mst) + + - Moose::Object + - BUILDALL and DEMOLISHALL now call + ->body when looping through the + methods, to avoid the overloaded + method call. + - fixed issue where DEMOLISHALL was + eating the $@ values, and so not + working correctly, it still kind of + eats them, but so does vanilla perl + - added tests for this + + - Moose::Cookbook::Recipe7 + - added new recipe for immutable + functionality (thanks Dave Rolsky) + + - Moose::Cookbook::Recipe9 + - added new recipe for builder and + lazy_build (thanks Dave Rolsky) + + - Moose::Cookbook::Recipe11 + - added new recipe for method aliasing + and exclusion with Roles (thanks Dave Rolsky) + + - t/ + - fixed Win32 test failure (thanks spicyjack) + + ~ removed Build.PL and Module::Build compat + since Module::Install has done that. + +0.43 2008-04-30 + - NOTE TO SELF: + drink more coffee before + doing release engineering + + - whoops, forgot to do the smolder tests, + and we broke some of the custom meta-attr + modules. This fixes that. + +0.42 2008-04-28 + - some bad tests slipped by, nothing else + changed in this release (cpantesters++) + + - upped the Class::MOP dependency to 0.55 + since we have tests which need the C3 + support + +0.41 2008-04-28 + ~~ numerous documentation updates ~~ + + - Changed all usage of die to Carp::croak for better + error reporting (initial patch by Tod Hagan) + + ** IMPORTANT NOTE ** + - the make_immutable keyword is now deprecated, don't + use it in any new code and please fix your old code + as well. There will be 2 releases, and then it will + be removed. + + - Moose + Moose::Role + Moose::Meta::Class + - refactored the way inner and super work to avoid + any method/@ISA cache penalty (nothingmuch) + + - Moose::Meta::Class + - fixing &new_object to make sure trigger gets the + coerced value (spotted by Charles Alderman on the + mailing list) + - added test for this + + - Moose::Meta::Method::Constructor + - immutable classes which had non-lazy attributes were calling + the default generating sub twice in the constructor. (bug + found by Jesse Luehrs, fixed by Dave Rolsky) + - added tests for this (Dave Rolsky) + - fix typo in initialize_body method (nothingmuch) + + - Moose::Meta::Method::Destructor + - fix typo in initialize_body method (nothingmuch) + + - Moose::Meta::Method::Overriden + Moose::Meta::Method::Augmented + - moved the logic for these into their own + classes (nothingmuch) + + - Moose::Meta::Attribute + - inherited attributes may now be extended without + restriction on the type ('isa', 'does') (Sartak) + - added tests for this (Sartak) + - when an attribute property is malformed (such as lazy without + a default), give the name of the attribute in the error + message (Sartak) + - added the &applied_traits and &has_applied_traits methods + to allow introspection of traits + - added tests for this + - moved 'trait' and 'metaclass' argument handling to here from + Moose::Meta::Class + - clone_and_inherit_options now handles 'trait' and 'metaclass' (has + '+foo' syntax) (nothingmuch) + - added tests for this (t0m) + + - Moose::Object + - localize $@ inside DEMOLISHALL to avoid it + eating $@ (found by Ernesto) + - added test for this (thanks to Ernesto) + + - Moose::Util::TypeConstraints + - &find_type_constraint now DWIMs when given an + type constraint object or name (nothingmuch) + - &find_or_create_type_constraint superseded with a number of more + specific functions: + - find_or_create_{isa,does}_type_constraint + - find_or_parse_type_constraint + + - Moose::Meta::TypeConstraint + Moose::Meta::TypeConstraint::Class + Moose::Meta::TypeConstraint::Role + Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::Union + Moose::Meta::TypeConstraint::Parameterized + - added the &equals method for comparing two type + constraints (nothingmuch) + - added tests for this (nothingmuch) + + - Moose::Meta::TypeConstraint + - add the &parents method, which is just an alias to &parent. + Useful for polymorphism with TC::{Class,Role,Union} (nothingmuch) + + - Moose::Meta::TypeConstraint::Class + - added the class attribute for introspection purposes + (nothingmuch) + - added tests for this + + - Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::Role + - broke these out into their own classes (nothingmuch) + + - Moose::Cookbook::Recipe* + - fixed references to test file locations in the POD + and updated up some text for new Moose features + (Sartak) + + - Moose::Util + - Added &resolve_metaclass_alias, a helper function for finding an actual + class for a short name (e.g. in the traits list) + +0.40 2008-03-14 + - I hate Pod::Coverage + +0.39 2008-03-14 + - Moose + - documenting the use of '+name' with attributes + that come from recently composed roles. It makes + sense, people are using it, and so why not just + officially support it. + - fixing the 'extends' keyword so that it will not + trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763) + + - oose + - added the perl -Moose=+Class::Name feature to allow + monkeypatching of classes in one liners + + - Moose::Util + - fixing the 'apply_all_roles' keyword so that it will not + trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763) + + - Moose::Meta::Class + - added ->create method which now supports roles (thanks to jrockway) + - added tests for this + - added ->create_anon_class which now supports roles and caching of + the results (thanks to jrockway) + - added tests for this + - made ->does_role a little more forgiving when it is + checking a Class::MOP era metaclasses. + + - Moose::Meta::Role::Application::ToInstance + - it is now possible to pass extra params to be used when + a role is applied to an the instance (rebless_params) + - added tests for this + + - Moose::Util::TypeConstraints + - class_type now accepts an optional second argument for a + custom message. POD anotated accordingly (groditi) + - added tests for this + - it is now possible to make anon-enums by passing 'enum' an + ARRAY ref instead of the $name => @values. Everything else + works as before. + - added tests for this + + - t/ + - making test for using '+name' on attributes consumed + from a role, it works and makes sense too. + + - Moose::Meta::Attribute + - fix handles so that it doesn't return nothing + when the method cannot be found, not sure why + it ever did this originally, this means we now + have slightly better support for AUTOLOADed + objects + - added more delegation tests + - adding ->does method to this so as to better + support traits and their introspection. + - added tests for this + + - Moose::Object + - localizing the Data::Dumper configurations so + that it does not pollute others (RT #33509) + - made ->does a little more forgiving when it is + passed Class::MOP era metaclasses. + +0.38 2008-02-15 + - Moose::Meta::Attribute + - fixed initializer to correctly do + type checking and coercion in the + callback + - added tests for this + + - t/ + - fixed some finicky tests (thanks to konobi) + +0.37 2008-02-14 + - Moose + - fixed some details in Moose::init_meta + and its superclass handling (thanks thepler) + - added tests for this (thanks thepler) + - 'has' now dies if you don't pass in name + value pairs + - added the 'make_immutable' keyword as a shortcut + to make_immutable + + - Moose::Meta::Class + Moose::Meta::Method::Constructor + Moose::Meta::Attribute + - making (init_arg => undef) work here too + (thanks to nothingmuch) + + - Moose::Meta::Attribute + Moose::Meta::Method::Constructor + Moose::Meta::Method::Accessor + - make lazy attributes respect attr initializers (rjbs) + - added tests for this + + - Moose::Util::TypeConstraints + Moose::Util::TypeConstraints::OptimizedConstraints + Moose::Meta::TypeConstraints + Moose::Meta::Attribute + Moose::Meta::Method::Constructor + Moose::Meta::Method::Accessor + - making type errors use the + assigned message (thanks to Sartak) + - added tests for this + + - Moose::Meta::Method::Destructor + - making sure DESTROY gets inlined properly + with successive DEMOLISH calls (thanks to manito) + + - Moose::Meta::Attribute + Moose::Meta::Method::Accessor + - fixed handling of undef with type constraints + (thanks to Ernesto) + - added tests for this + + - Moose::Util + - added &get_all_init_args and &get_all_attribute_values + (thanks to Sartak and nothingmuch) + +0.36 2008-01-26 + - Moose::Role + Moose::Meta::Attribute + - role type tests now support when roles are + applied to non-Moose classes (found by ash) + - added tests for this (thanks to ash) + - couple extra tests to boost code coverage + + - Moose::Meta::Method::Constructor + - improved fix for handling Class::MOP attributes + - added test for this + + - Moose::Meta::Class + - handled the add_attribute($attribute_meta_object) + case correctly + - added test for this + +0.35 2008-01-22 + - Moose::Meta::Method::Constructor + - fix to make sure even Class::MOP attributes + are handled correctly (Thanks to Dave Rolsky) + - added test for this (also Dave Rolsky) + + - Moose::Meta::Class + - improved error message on _apply_all_roles, + you should now use Moose::Util::apply_all_roles + and you shouldnt have been using a _ prefixed + method in the first place ;) + +0.34 2008-01-21 + ~~~ more misc. doc. fixes ~~~ + ~~ updated copyright dates ~~ + + Moose is now a postmodern object system :) + - (see the POD for details) + + - <<Role System Refactoring>> + - this release contains a major reworking and + cleanup of the role system + - 100% backwards compat. + - Role application now restructured into seperate + classes based on type of applicants + - Role summation (combining of more than one role) + is much cleaner and anon-classes are no longer + used in this process + - new Composite role metaclass + - runtime application of roles to instances + is now more efficient and re-uses generated + classes when applicable + + - <<New Role composition features>> + - methods can now be excluded from a given role + during composition + - methods can now be aliased to another name (and + still retain the original as well) + + - Moose::Util::TypeConstraints::OptimizedConstraints + - added this module (see above) + + - Moose::Meta::Class + - fixed the &_process_attribute method to be called + by &add_attribute, so that the API is now correct + + - Moose::Meta::Method::Accessor + - fixed bug when passing a list of values to + an accessor would get (incorrectly) ignored. + Thanks to Sartak for finding this ;) + - added tests for this (Sartak again) + + - Moose::Meta::Method::Accessor + Moose::Meta::Method::Constructor + Moose::Meta::Attribute + Moose::Meta::TypeConstraint + Moose::Meta::TypeCoercion + - lots of cleanup of such things as: + - generated methods + - type constraint handling + - error handling/messages + (thanks to nothingmuch) + + - Moose::Meta::TypeConstraint::Parameterizable + - added this module to support the refactor + in Moose::Meta::TypeConstraint::Parameterized + + - Moose::Meta::TypeConstraint::Parameterized + - refactored how these types are handled so they + are more generic and not confined to ArrayRef + and HashRef only + + - t/ + - shortened some file names for better VMS support (RT #32381) + +0.33 2007-12-14 + !! Moose now loads 2 x faster !! + !! with new Class::MOP 0.49 !! + + ++ new oose.pm module to make command line + Moose-ness easier (see POD docs for more) + + - Moose::Meta::Class + - Moose::Meta::Role + - several tweaks to take advantage of the + new method map caching in Class::MOP + + - Moose::Meta::TypeConstraint::Parameterized + - allow subtypes of ArrayRef and HashRef to + be used as a container (sartak) + - added tests for this + - basic support for coercion to ArrayRef and + HashRef for containers (sartak) + - added tests for this + + - Moose::Meta::TypeCoercion + - coercions will now create subtypes as needed + so you can now add coercions to parameterized + types without having to explictly define them + - added tests for this + + - Moose::Meta::Method::Accessor + - allow subclasses to decide whether we need + to copy the value into a new variable (sartak) + +0.32 2007-12-04 + - Moose::Util::TypeConstraints + - fixing how subtype aliases of unions work + they should inherit the parent's coercion + - added tests for this + - you can now define multiple coercions on + a single type at different times instead of + having to do it all in one place + - added tests for this + + - Moose::Meta::TypeConstraint + - there is now a default constraint of sub { 1 } + instead of Moose::Util::TypeConstraints setting + this for us + + - Moose::Meta::TypeCoercion + - Moose::Meta::TypeCoercion::Union + - added the &has_coercion_for_type and + &add_type_coercions methods to support the + new features above (although you cannot add + more type coercions for Union types) + +0.31 2007-11-26 + - Moose::Meta::Attribute + - made the +attr syntax handle extending types with + parameters. So "has '+foo' => (isa => 'ArrayRef[Int]')" + now works if the original foo is an ArrayRef. + - added tests for this. + - delegation now works even if the attribute does not + have a reader method using the get_read_method_ref + method from Class::MOP::Attribute. + - added tests for this + - added docs for this + + - Moose::Util::TypeConstraints + - passing no "additional attribute info" to + &find_or_create_type_constraint will no longer + attempt to create an __ANON__ type for you, + instead it will just return undef. + - added docs for this + +0.30 2007-11-23 + - Moose::Meta::Method::Constructor + -builder related bug in inlined constructor. (groditi) + + - Moose::Meta::Method::Accessor + - genereate unnecessary calls to predicates and refactor + code generation for runtime speed (groditi) + + - Moose::Util::TypeConstraints + - fix ClassName constraint to introspect symbol table (mst) + - added more tests for this (mst) + - fixed it so that subtype 'Foo' => as 'HashRef[Int]' ... + with work correctly. + - added tests for this + + - Moose::Cookbook + - adding the link to Recipie 11 (written by Sartak) + - adding test for SYNOPSIS code + + - t/ + - New tests for builder bug. Upon instantiation, if an + attribute had a builder, no value and was not lazy the + builder default was not getting run, oops. (groditi) + +0.29 2007-11-13 + - Moose::Meta::Attribute + - Fix error message on missing builder method (groditi) + + - Moose::Meta::Method::Accessor + - Fix error message on missing builder method (groditi) + + - t/ + - Add test to check for the correct error message when + builder method is missing (groditi) + +0.28 2007-11-13 + - 0.27 packaged incorrectly (groditi) + +0.27 2007-11-13 + - Moose::Meta::Attribute + - Added support for the new builder option (groditi) + - Added support for lazy_build option (groditi) + - Changed slot initialization for predicate changes (groditi) + + - Moose::Meta::Method::Accessor + - Added support for lazy_build option (groditi) + - Fix inline methods to work with corrected predicate + behavior (groditi) + + - Moose::Meta::Method::Constructor + - Added support for lazy_build option (groditi) + + - t/ + - tests for builder and lazy_build (groditi) + + - fixing some misc. bits in the docs that + got mentioned on CPAN Forum & perlmonks + + - Moose::Meta::Role + - fixed how required methods are handled + when they encounter overriden or modified + methods from a class (thanks to confound). + - added tests for this + + - Moose::Util::TypeConstraint + - fixed the type notation parser so that + the | always creates a union and so is + no longer a valid type char (thanks to + konobi, mugwump and #moose for working + this one out.) + - added more tests for this + +0.26 2007-09-27 + == New Features == + + - Parameterized Types + We now support parameterized collection types, such as: + ArrayRef[Int] # array or integers + HashRef[Object] # a hash with object values + They can also be nested: + ArrayRef[HashRef[RegexpRef]] # an array of hashes with regex values + And work with the type unions as well: + ArrayRef[Int | Str] # array of integers of strings + + - Better Framework Extendability + Moose.pm is now "extendable" such that it is now much + easier to extend the framework and add your own keywords + and customizations. See the "EXTENDING AND EMBEDDING MOOSE" + section of the Moose.pm docs. + + - Moose Snacks! + In an effort to begin documenting some of the various + details of Moose as well as some common idioms, we have + created Moose::Cookbook::Snacks as a place to find + small (easily digestable) nuggets of Moose code. + + ==== + ~ Several doc updates/cleanup thanks to castaway ~ + + - converted build system to use Module::Install instead of + Module::Build (thanks to jrockway) + + - Moose + - added all the meta classes to the immutable list and + set it to inline the accessors + - fix import to allow Sub::Exporter like { into => } + and { into_level => } (perigrin) + - exposed and documented init_meta() to allow better + embedding and extending of Moose (perigrin) + + - t/ + - complete re-organization of the test suite + - added some new tests as well + - finally re-enabled the Moose::POOP test since + the new version of DBM::Deep now works again + (thanks rob) + + - Moose::Meta::Class + - fixed very odd and very nasty recursion bug with + inner/augment (mst) + - added tests for this (eilara) + + - Moose::Meta::Attribute + Moose::Meta::Method::Constructor + Moose::Meta::Method::Accessor + - fixed issue with overload::Overloaded getting called + on non-blessed items. (RT #29269) + - added tests for this + + - Moose::Meta::Method::Accessor + - fixed issue with generated accessor code making + assumptions about hash based classes (thanks to dexter) + + - Moose::Coookbook::Snacks + - these are bits of documentation, not quite as big as + Recipes but which have no clear place in the module docs. + So they are Snacks! (horray for castaway++) + + - Moose::Cookbook::Recipe4 + - updated it to use the new ArrayRef[MyType] construct + - updated the accompanying test as well + + +++ Major Refactor of the Type Constraint system +++ + +++ with new features added as well +++ + + - Moose::Util::TypeConstraint + - no longer uses package variable to keep track of + the type constraints, now uses the an instance of + Moose::Meta::TypeConstraint::Registry to do it + - added more sophisticated type notation parsing + (thanks to mugwump) + - added tests for this + + - Moose::Meta::TypeConstraint + - some minor adjustments to make subclassing easier + - added the package_defined_in attribute so that we + can track where the type constraints are created + + - Moose::Meta::TypeConstraint::Union + - this is now been refactored to be a subclass of + Moose::Meta::TypeConstraint + + - Moose::Meta::TypeCoercion::Union + - this has been added to service the newly refactored + Moose::Meta::TypeConstraint::Union and is itself + a subclass of Moose::Meta::TypeCoercion + + - Moose::Meta::TypeConstraint::Parameterized + - added this module (taken from MooseX::AttributeHelpers) + to help construct nested collection types + - added tests for this + + - Moose::Meta::TypeConstraint::Registry + - added this class to keep track of type constraints + +0.25 2007-08-13 + - Moose + - Documentation update to reference Moose::Util::TypeConstraints + under 'isa' in 'has' for how to define a new type + (thanks to shlomif). + + - Moose::Meta::Attribute + - required attributes now will no longer accept undef + from the constructor, even if there is a default and lazy + - added tests for this + - default subroutines must return a value which passes the + type constraint + - added tests for this + + - Moose::Meta::Attribute + - Moose::Meta::Method::Constructor + - Moose::Meta::Method::Accessor + - type-constraint tests now handle overloaded objects correctly + in the error message + - added tests for this (thanks to EvanCarroll) + + - Moose::Meta::TypeConstraint::Union + - added (has_)hand_optimized_constraint to this class so that + it behaves as the regular Moose::Meta::TypeConstraint does. + + - Moose::Meta::Role + - large refactoring of this code + - added several more tests + - tests for subtle conflict resolition issues + added, but not currently running + (thanks to kolibre) + + - Moose::Cookbook::Recipe7 + - added new recipe for augment/inner functionality + (still in progress) + - added test for this + + - Moose::Spec::Role + - a formal definition of roles (still in progress) + + - Moose::Util + - utilities for easier working with Moose classes + - added tests for these + + - Test::Moose + - This contains Moose specific test functions + - added tests for these + +0.24 2007-07-03 + ~ Some doc updates/cleanup ~ + + - Moose::Meta::Attribute + - added support for roles to be given as parameters + to the 'handles' option. + - added tests and docs for this + - the has '+foo' attribute form now accepts changes to + the lazy option, and the addition of a handles option + (but not changing the handles option) + - added tests and docs for this + + - Moose::Meta::Role + - required methods are now fetched using find_method_by_name + so that required methods can come from superclasses + - adjusted tests for this + +0.23 2007-06-18 + - Moose::Meta::Method::Constructor + - fix inlined constructor for hierarchy with multiple BUILD methods (mst) + - Moose::Meta::Class + - Modify make_immutable to work with the new Class::MOP immutable + mechanism + POD + very basic test (groditi) + - Moose::Meta::Attribute + - Fix handles to use goto() so that caller() comes out properly on + the other side (perigrin) + +0.22 2007-05-31 + - Moose::Util::TypeConstraints + - fix for prototype undeclared issue when Moose::Util::TypeConstraints + loaded before consumers (e.g. Moose::Meta::Attribute) by predeclaring + prototypes for functions + - added the ClassName type constraint, this checks for strings + which will respond true to ->isa(UNIVERSAL). + - added tests and docs for this + - subtyping just in name now works correctly by making the + default for where be { 1 } + - added test for this + + - Moose::Meta::Method::Accessor + - coerce and lazy now work together correctly, thanks to + merlyn for finding this bug + - tests added for this + - fix reader presedence bug in Moose::Meta::Attribute + tests + + - Moose::Object + - Foo->new(undef) now gets ignored, it is assumed you meant to pass + a HASH-ref and missed. This produces better error messages then + having it die cause undef is not a HASH. + - added tests for this + +0.21 2007-05-03 + - Moose + - added SUPER_SLOT and INNER_SLOT class hashes to support unimport + - modified unimport to remove super and inner along with the rest + - altered unimport tests to handle this + + - Moose::Role + - altered super export to populate SUPER_SLOT + + - Moose::Meta::Class + - altered augment and override modifier application to use *_SLOT + - modified tests for these to unimport one test class each to test + + - Moose::Meta::Role + - fixed issue where custom attribute metaclasses + where not handled correctly in roles + - added tests for this + + - Moose::Meta::Class + - fixed issue where extending metaclasses with + roles would blow up. Thanks to Aankhen`` for + finding this insidious error, and it's solution. + + ~~ lots of spelling and grammer fixes in the docs, + many many thanks to rlb3 and Aankhen for these :) + +0.20 2007-04-06 + >> I messed up the SKIP logic in one test + so this release is just to fix that. + + - Moose + - 'has' now also accepts an ARRAY ref + to create multiple attrs (see docs) + (thanks to konobi for this) + - added tests and docs + +0.19 2007-04-05 + ~~ More documentation updates ~~ + + - Moose::Util::TypeConstraints + - 'type' now supports messages as well + thanks to phaylon for finding this + - added tests for this + - added &list_all_type_constraints and + &list_all_builtin_type_constraints + functions to facilitate introspection. + + - Moose::Meta::Attribute + - fixed regexp 'handles' declarations + to build the list of delegated methods + correctly (and not override important + things like &new) thanks to ashleyb + for finding this + - added tests and docs for this + - added the 'documentation' attributes + so that you can actually document your + attributes and inspect them through the + meta-object. + - added tests and docs for this + + - Moose::Meta::Class + - when loading custom attribute metaclasses + it will first look in for the class in the + Moose::Meta::Attribute::Custom::$name, and + then default to just loading $name. + - added tests and docs for this + + - Moose::Meta::TypeConstraint + - type constraints now stringify to their names. + - added test for this + + - misc. + - added tests to assure we work with Module::Refresh + - added stricter test skip logic in the Moose POOP + test, ask Rob Kinyon why. + - *cough* DBM::Deep 1.0 backwards compatibility sucks *cough* ;) + +0.18 2007-03-10 + ~~ Many, many documentation updates ~~ + + - misc. + - We now use Class::MOP::load_class to + load all classes. + - added tests to show types and subtypes + working with Declare::Constraints::Simple + and Test::Deep as constraint engines. + +0.18_001 2006-11-26 + !! You must have Class::MOP 0.37_001 !! + !! for this developer release to work !! + + This release was primarily adding the immutable + feature to Moose. An immutable class is one which + you promise not to alter. When you set the class + as immutable it will perform various bits of + memoization and inline certain part of the code + (constructors, destructors and accessors). This + minimizes (and in some cases totally eliminates) + one of Moose's biggest performance hits. This + feature is not on by default, and is 100% optional. + It has several configurable bits as well, so you + can pick and choose to your specific needs. + + The changes involved in this were fairly wide and + highly specific, but 100% backwards compatible, so + I am not going to enumerate them here. If you are + truely interested in what was changed, please do + a diff :) + +0.17 2006-11-14 + - Moose::Meta::Method::Accessor + - bugfix for read-only accessors which + are have a type constraint and lazy. + Thanks to chansen for finding it. + +0.16 2006-11-14 + ++ NOTE ++ + There are some speed improvements in this release, + but they are only the begining, so stay tuned. + + - Moose::Object + - BUILDALL and DEMOLISHALL no longer get + called unless they actually need to be. + This gave us a signifigant speed boost + for the cases when there is no BUILD or + DEMOLISH method present. + + - Moose::Util::TypeConstraints + - Moose::Meta::TypeConstraint + - added an 'optimize_as' option to the + type constraint, which allows for a + hand optimized version of the type + constraint to be used when possible. + - Any internally created type constraints + now provide an optimized version as well. + +0.15 2006-11-05 + ++ NOTE ++ + This version of Moose *must* have Class::MOP 0.36 in order + to work correctly. A number of small internal tweaks have + been made in order to be compatible with that release. + + - Moose::Util::TypeConstraints + - added &unimport so that you can clean out + your class namespace of these exported + keywords + + - Moose::Meta::Class + - fixed minor issue which occasionally + comes up during global destruction + (thanks omega) + - moved Moose::Meta::Method::Overriden into + its own file. + + - Moose::Meta::Role + - moved Moose::Meta::Role::Method into + its own file. + + - Moose::Meta::Attribute + - changed how we do type checks so that + we reduce the overall cost, but still + retain correctness. + *** API CHANGE *** + - moved accessor generation methods to + Moose::Meta::Method::Accessor to + conform to the API changes from + Class::MOP 0.36 + + - Moose::Meta::TypeConstraint + - changed how constraints are compiled + so that we do less recursion and more + iteration. This makes the type check + faster :) + - moved Moose::Meta::TypeConstraint::Union + into its own file + + - Moose::Meta::Method::Accessor + - created this from methods formerly found in + Moose::Meta::Attribute + + - Moose::Meta::Role::Method + - moved this from Moose::Meta::Role + + - Moose::Meta::Method::Overriden + - moved this from Moose::Meta::Class + + - Moose::Meta::TypeConstraint::Union + - moved this from Moose::Meta::TypeConstraint + +0.14 2006-10-09 + + - Moose::Meta::Attribute + - fixed lazy attributes which were not getting + checked with the type constraint (thanks ashley) + - added tests for this + - removed the over-enthusiastic DWIMery of the + automatic ArrayRef and HashRef defaults, it + broke predicates in an ugly way. + - removed tests for this + +0.13 2006-09-30 + ++ NOTE ++ + This version of Moose *must* have Class::MOP 0.35 in order + to work correctly. A number of small internal tweaks have + been made in order to be compatible with that release. + + - Moose + - Removed the use of UNIVERSAL::require to be a better + symbol table citizen and remove a dependency + (thanks Adam Kennedy) + + **~~ removed experimental & undocumented feature ~~** + - commented out the 'method' and 'self' keywords, see the + comments for more info. + + - Moose::Cookbook + - added a FAQ and WTF files to document frequently + asked questions and common problems + + - Moose::Util::TypeConstraints + - added GlobRef and FileHandle type constraint + - added tests for this + + - Moose::Meta::Attribute + - if your attribute 'isa' ArrayRef of HashRef, and you have + not explicitly set a default, then make the default DWIM. + This will also work for subtypes of ArrayRef and HashRef + as well. + - you can now auto-deref subtypes of ArrayRef or HashRef too. + - new test added for this (thanks to ashley) + + - Moose::Meta::Role + - added basic support for runtime role composition + but this is still *highly experimental*, so feedback + is much appreciated :) + - added tests for this + + - Moose::Meta::TypeConstraint + - the type constraint now handles the coercion process + through delegation, this is to support the coercion + of unions + + - Moose::Meta::TypeConstraint::Union + - it is now possible for coercions to be performed + on a type union + - added tests for this (thanks to konobi) + + - Moose::Meta::TypeCoercion + - properly capturing error when type constraint + is not found + + - Build.PL + - Scalar::Util 1.18 is bad on Win32, so temporarily + only require version 1.17 for Win32 and cygwin. + (thanks Adam Kennedy) + +0.12 2006-09-01 + - Moose::Cookbook + - Recipe5 (subtypes & coercion) has been written + + - Moose + - fixed "bad meta" error message to be more descriptive + - fixed &unimport to not remove the &inner and &super + keywords because we need to localize them. + - fixed number of spelling/grammer issues, thanks Theory :) + + **~~ experimental & undocumented feature ~~** + - added the method and self keywords, they are basically + just sugar, and they may not stay around. + + - Moose::Object + - added &dump method to easily Data::Dumper + an object + + - Moose::Meta::TypeConstraint + - added the &is_a_type_of method to check both the current + and the subtype of a method (similar to &isa with classes) + + - Moose::Meta::Role + - this is now a subclass of Class::MOP::Module, and no longer + creates the _role_meta ugliness of before. + - fixed tests to reflect this change + +0.11 2006-07-12 + - Moose + - added an &unimport method to remove all the keywords + that Moose will import, simply add 'no Moose' to the + bottom of your class file. + + - t/ + - fixed some test failures caused by a forgotten test + dependency. + +0.10 2006-07-06 + - Moose + - improved error message when loading modules so + it is less confusing when you load a role. + - added &calculate_all_roles method to + Moose::Meta::Class and Moose::Meta::Role + + NOTE: + This module has been tested against Class::MOP 0.30 + but it does not yet utilize the optimizations + it makes available. Stay tuned for that ;) + +0.09_03 2006-06-23 + ++ DEVELOPER RELEASE ++ + - Moose + - 'use strict' and 'use warnings' are no longer + needed in Moose classes, Moose itself will + turn them on for you. + - added tests for this + - moved code from exported subs to private methods + in Moose::Meta::Class + + - Moose::Role + - as with Moose, strict and warnings are + automatically turned on for you. + - added tests for this + + - Moose::Meta::Role + - now handles an edge case for override errors + - added tests for this + - added some more edge case tests + +0.09_02 2006-05-16 + ++ DEVELOPER RELEASE ++ + - Moose + - added prototypes to the exported subs + - updated docs + + - Moose::Role + - added prototypes to the exported subs + - updated docs + + - Moose::Util::TypeConstraints + - cleaned up prototypes for the subs + - updated docs + +0.09_01 2006-05-12 + ++ DEVELOPER RELEASE ++ + - This release works in combination with + Class::MOP 0.29_01, it is a developer + release because it uses the a new + instance sub-protocol and a fairly + complete Role implementation. It has + not yet been optimized, so it slower + the the previous CPAN version. This + release also lacks good updated docs, + the official release will have updated docs. + + - Moose + - refactored the keyword exports + - 'with' now checks Role validaity and + accepts more than one Role at a time + - 'extends' makes metaclass adjustments as + needed to ensure metaclass compatibility + + - Moose::Role + - refactored the keyword exports + - 'with' now checks Role validaity and + accepts more than one Role at a time + + - Moose::Util::TypeConstraints + - added the 'enum' keyword for simple + string enumerations which can be used as + type constraints + - see example of usage in t/202_example.t + + - Moose::Object + - more careful checking of params to new() + + - Moose::Meta::Role + - much work done on the role composition + - many new tests for conflict detection + and composition edge cases + - not enough documentation, I suggest + looking at the tests + + - Moose::Meta::Instance + - added new Instance metaclass to support + the new Class::MOP instance protocol + + - Moose::Meta::Class + - some small changes to support the new + instance protocol + - some small additions to support Roles + + - Moose::Meta::Attribute + - some improvements to the accessor generation code + by nothingmuch + - some small changes to support the new + instance protocol + - (still somewhat) experimental delegation support + with the 'handles' option + - added several tests for this + - no docs for this yet + +0.05 2006-04-27 + - Moose + - keywords are now exported with Sub::Exporter + thanks to chansen for this commit + - has keyword now takes a 'metaclass' option + to support custom attribute meta-classes + on a per-attribute basis + - added tests for this + - the 'has' keyword not accepts inherited slot + specifications (has '+foo'). This is still an + experimental feature and probably not finished + see t/038_attribute_inherited_slot_specs.t for + more details, or ask about it on #moose + - added tests for this + + - Moose::Role + - keywords are now exported with Sub::Exporter + + - Moose::Utils::TypeConstraints + - reorganized the type constraint hierarchy, thanks + to nothingmuch and chansen for his help and advice + on this + - added some tests for this + - keywords are now exported with Sub::Exporter + thanks to chansen for this commit + + - Moose::Meta::Class + - due to changes in Class::MOP, we had to change + construct_instance (for the better) + + - Moose::Meta::Attribute + - due to changes in Class::MOP, we had to add the + initialize_instance_slot method (it's a good thing) + + - Moose::Meta::TypeConstraint + - added type constraint unions + - added tests for this + - added the is_subtype_of predicate method + - added tests for this + +0.04 2006-04-16 + - Moose::Role + - Roles can now consume other roles + - added tests for this + - Roles can specify required methods now with + the requires() keyword + - added tests for this + + - Moose::Meta::Role + - ripped out much of it's guts ,.. much cleaner now + - added required methods and correct handling of + them in apply() for both classes and roles + - added tests for this + - no longer adds a does() method to consuming classes + it relys on the one in Moose::Object + - added roles attribute and some methods to support + roles consuming roles + + - Moose::Meta::Attribute + - added support for triggers on attributes + - added tests for this + - added support for does option on an attribute + - added tests for this + + - Moose::Meta::Class + - added support for attribute triggers in the + object construction + - added tests for this + + - Moose + - Moose no longer creates a subtype for your class + if a subtype of the same name already exists, this + should DWIM in 99.9999% of all cases + + - Moose::Util::TypeConstraints + - fixed bug where incorrect subtype conflicts were + being reported + - added test for this + + - Moose::Object + - this class can now be extended with 'use base' if + you need it, it properly loads the metaclass class now + - added test for this + +0.03_02 2006-04-12 + - Moose + - you must now explictly use Moose::Util::TypeConstraints + it no longer gets exported for you automatically + + - Moose::Object + - new() now accepts hash-refs as well as key/value lists + - added does() method to check for Roles + - added tests for this + + - Moose::Meta::Class + - added roles attribute along with the add_role() and + does_role() methods + - added tests for this + + - Moose::Meta::Role + - now adds a does() method to consuming classes + which tests the class's hierarchy for roles + - added tests for this + +0.03_01 2006-04-10 + - Moose::Cookbook + - added new Role recipe (no content yet, only code) + + - Moose + - added 'with' keyword for Role support + - added test and docs for this + - fixed subtype quoting bug + - added test for this + + - Moose::Role + - Roles for Moose + - added test and docs + + - Moose::Util::TypeConstraints + - added the message keyword to add custom + error messages to type constraints + + - Moose::Meta::Role + - the meta role to support Moose::Role + - added tests and docs + + - Moose::Meta::Class + - moved a number of things from Moose.pm + to here, they should have been here + in the first place + + - Moose::Meta::Attribute + - moved the attribute option macros here + instead of putting them in Moose.pm + + - Moose::Meta::TypeConstraint + - added the message attributes and the + validate method + - added tests and docs for this + +0.03 2006-03-30 + - Moose::Cookbook + - added the Moose::Cookbook with 5 recipes, + describing all the stuff Moose can do. + + - Moose + - fixed an issue with &extends super class loading + it now captures errors and deals with inline + packages correctly (bug found by mst, solution + stolen from alias) + - added super/override & inner/augment features + - added tests and docs for these + + - Moose::Object + - BUILDALL now takes a reference of the %params + that are passed to &new, and passes that to + each BUILD as well. + + - Moose::Util::TypeConstraints + - Type constraints now survive runtime reloading + - added test for this + + - Moose::Meta::Class + - fixed the way attribute defaults are handled + during instance construction (bug found by chansen) + + - Moose::Meta::Attribute + - read-only attributes now actually enforce their + read-only-ness (this corrected in Class::MOP as + well) + +0.02 2006-03-21 + - Moose + - many more tests, fixing some bugs and + edge cases + - &extends now loads the base module with + UNIVERSAL::require + - added UNIVERSAL::require to the + dependencies list + ** API CHANGES ** + - each new Moose class will also create + and register a subtype of Object which + correspond to the new Moose class. + - the 'isa' option in &has now only + accepts strings, and will DWIM in + almost all cases + + - Moose::Util::TypeConstraints + - added type coercion features + - added tests for this + - added support for this in attributes + and instance construction + ** API CHANGES ** + - type construction no longer creates a + function, it registers the type instead. + - added several functions to get the + registered types + + - Moose::Object + - BUILDALL and DEMOLISHALL were broken + because of a mis-named hash key, Whoops :) + + - Moose::Meta::Attribute + - adding support for coercion in the + autogenerated accessors + + - Moose::Meta::Class + - adding support for coercion in the + instance construction + + - Moose::Meta::TypeConstraint + - Moose::Meta::TypeCoercion + - type constraints and coercions are now + full fledges meta-objects + +0.01 2006-03-15 + - Moooooooooooooooooose!!! diff --git a/Changes.Class-MOP b/Changes.Class-MOP new file mode 100644 index 0000000..df209b5 --- /dev/null +++ b/Changes.Class-MOP @@ -0,0 +1,1800 @@ +After 1.12, Class::MOP was merged into the Moose distribution, and is no +longer released separately. + +1.12 Mon, Jan 3, 2011 + + * Remove usage of undocumented Package::Stash APIs from the tests. This + prevents the tests from failing on Package::Stash >= 0.18. + +1.11 Sun, Oct 31, 2010 + + [ENHANCEMENTS] + + * Replace use of Test::Exception with Test::Fatal. (Karen Etheridge and Dave + Rolsky) + +1.10 Mon, Oct 18, 2010 + + [BUG FIXES] + + * Lots of fixes for edge cases with anon classes. (doy) + +1.09 Tue, Oct 5, 2010 + + [ENHANCEMENTS] + + * It's now possible to tell Class::MOP::Class->create and the metaclass + pragma to not install a 'meta' method into classes they manipulate, + or to install one under a different name. (doy) + + * Reinitializing a metaclass no longer removes the existing method and + attribute objects (it instead fixes them so they are correct for the + reinitialized metaclass). (doy) + + * All 'meta' methods created by Class::MOP are now of the class + Class::MOP::Method::Meta. This is overridable at the metaclass layer. (doy) + + [OTHER] + + * Use get_or_add_package_symbol when we intend for it to autovivify, in + preparation for changes in Package::Stash. (doy) + + * We now use Module::Install::AuthorRequires to force authors to run all + tests, just like we do for Moose. (sartak) + +1.08 Mon, Sep 13, 2010 + + [BUG FIXES] + + * The get_method_list and _get_local_methods methods blew up in the face + of subroutine stubs. (Goro Fuji) + +1.07 Tue, Aug 25, 2010 + + [BUG FIXES] + + * Fix a mysterious error reported by Piers Cawley. The error showed up as + "Can't use an undefined value as a symbol reference at + /usr/local/lib/perl/5.10.1/Class/MOP/Mixin/HasMethods.pm line 167." (Dave + Rolsky) + +1.06 Sun, Aug 23, 2010 + + [BUG FIXES] + + * Version 1.05 no longer reported constants as methods, except with Perl + 5.8.x, and doing so in 5.8.x caused test failures. Constants are now + _expected_ to be reported as methods, and we explicitly test this. (Dave + Rolsky) + +1.05 Sun, Aug 22, 2010 + + [ENHANCEMENTS] + + * Refactorings and improvements to how defaults are handled, particularly + for inlined code (doy). + + * Optimizations that should help speed up compilation time (Dave Rolsky). + +1.04 Tue, Jul 25, 2010 + + [ENHANCEMENTS] + + * Class::MOP::Deprecated now uses Package::DeprecationManager + internally. Deprecation warnings are now only issued once for each calling + package, which cuts down on noise. When importing Class::MOP::Deprecated, + the request API version should now be passed in the "-api_version" + flag. However, the old "-compatible" flag will continue to work. (Dave + Rolsky) + +1.03 Sat, Jun 5, 2010 + + [ENHANCEMENTS] + + * Make CMOP::Package a thin wrapper around Package::Stash (doy). + +1.02 Thu, May 20, 2010 + + [API CHANGES] + + * Packages and modules no longer have methods - this functionality was + moved back up into Class::MOP::Class (doy). + + [ENHANCEMENTS] + + * Metaclass incompatibility checking now checks all metaclass types. (doy) + + * Class::MOP can now do simple metaclass incompatibility fixing: if your + class's metaclass is a subclass of your parent class's metaclass, it will + just use the parent class's metaclass directly. (doy) + +1.01 Thu, May 6, 2010 + + [NEW FEATURES] + + * is_class_loaded, load_class and load_first_existing_class now allow + specifying a minimum required version (Florian Ragwitz). + + [BUG FIXES] + + * The __INSTANCE__ parameter to Class::MOP::Class::new_object now enforces + that the passed in reference is blessed into the correct class (by dying if + it's not) (doy, jhallock). + +1.00 Thu, Mar 25, 2010 + + [GRRR< FUCKING STEVAN@] + + * Re-release 0.99 as 1.00. + +0.99 Thu, Mar 25, 2010 + + [DOCUMENTATION] + + * Fix typo in Class::MOP::Attribute (Franck Cuny). + +0.98 Mon, Jan 18, 2010 + + [ENHANCEMENTS] + + * Added Class::MOP::Class->rebless_instance_back, which does the inverse of + rebless_instance (doy, rafl). + +0.97_01 Mon, Jan 4, 2010 + + [ENHANCEMENTS] + + * Internal refactorings to move shared behavior into new "mixin" classes. This + made adding some new features to Moose much easier. (Dave Rolsky) + +0.97 Fri, Dec 18, 2009 + * No code changes, just packaging fixes to make this distro installable. + +0.96 Fri, Dec 18, 2009 + * tests + - Fixed t/082_get_code_info.t so it passes with bleadperl. (Dave Rolsky) + - Add XS & C files to no tabs check (Dave Rolsky) + - Convert all tests to done_testing. (Florian Ragwitz) + +0.95 Wed, Nov 19, 2009 + * Class::MOP + - Make is_class_loaded without any arguments fail loudly + (Florian Ragwitz). + - Make load_class throw more standard error messages when loading single + modules (nothingmuch). + + * Class::MOP::Package + - Stop add_method from behaving differently under the debugger + (Florian Ragwitz). + + * Class::MOP::Class + * Class::MOP::Package + - Any method which takes a method name as an argument now allows names + which are false (like "0"), but the name must be defined and not be an + empty string. (Dave Rolsky) + + * Class::MOP::Class + - Deprecated get_attribute_map as a public method. You can use a + combination of get_attribute_list and get_attribute instead. (Dave + Rolsky) + +0.94 Tue, Sep 22, 2009 + * Class::MOP::Attribute + - Introduce set_raw_value and get_raw_value, side effect free variants + of {get,set}_value. These don't do anything useful in Class::MOP but + have different behavior that set_value and get_value for Moose + attributes. (nothingmuch) + +0.93 Tue, Sep 15, 2009 + * Class::MOP + - The load_class function just returns true, since it's return value was + confusing (either a metaclass object or a class name). It either loads + a class or dies trying. In the future, this may change to not return + anything, since there's no point in checking its return + value. Addresses RT #45883. (Dave Rolsky) + + * Class::MOP::Class::Trait::Immutable + - When throwing an error because of an immutable method, include that + method's name. Addresses RT #49680. (Shawn M Moore) + + * Class::MOP::Package + - Adding the same sub reference to multiple packages failed to update + the method map properly. RT #48985. Reported by Paul Mooney. (Dave + Rolsky) + - The get_method_map method is now private (and called as + _full_method_map or _method_map). The public version is available as a + deprecated method. (Dave Rolsky) + +0.92_01 Thu, Sep 10, 2009 + * Class::MOP::Package + - Backwards compatibility tweaks to XS for 5.8.1. (Goro Fuji) + + * Class::MOP + - Make sure XS code handles magical scalars correctly. (Goro Fuji) + + * Class::MOP::Class + - Documented the immutable_options method, which is useful if you need + to make a class mutable temporarily, and then nede to restore + immutability. (Dave Rolsky) + + * Many modules + - Deprecated features have been moved to their own module, + Class::MOP::Deprecated, for easier deprecation management. (Goro Fuji) + +0.92 Thu Aug 13, 2009 + * Class::MOP::Class + * Class::MOP::Package + - Move get_method_map and its various scaffolding into Package. (hdp) + + * Class::MOP::Method + - Allow Class::MOP::Method->wrap to take a Class::MOP::Method object as + the first argument, rather than just a coderef. (doy) + + * Class::MOP::Attribute + * Class::MOP::Class + - Allow attribute names to be false (while still requiring them to be + defined). (rafl) + +0.91 Wed Jul 29, 2009 + * Class::MOP::Method::Wrapped + - Fixing variable usage issues with the patch from previous + version, not properly using lexicals in the for + loops. (stevan) + +0.90 Tue Jul 21, 2009 + Japan Perl Association has sponsored Goro Fuji to improve startup + performance of Class::MOP and Moose. These enhancements may break + backwards compatibility if you're doing (or using) complex + metaprogramming, so, as always, test your code! + http://blog.perlassociation.org/2009/07/jpa-sponsors-moose-class-mop-work.html + + * Class::MOP::Class + * XS + - Anonymous classes were not completely destroyed when they went + out of scope, leading to a memory leak. RT #47480. (Goro + Fuji). + + * Class::MOP::Class + - The get_method, has_method, and add_method methods no longer + use get_method_map. Method objects are instantiated + lazily. This significantly improves Class::MOP's load + time. (Goro Fuji) + + * All classes + - Inline fewer metaclass-level constructors since the ones we + have are perfectly fine. This reduces the number of string + evals. (Goro Fuji) + + * Class::MOP::Method::Wrapped + - If a method modifier set $_, this caused the modifier to blow + up, because of some weird internals. (Jeremy Stashewsky) + +0.89 Fri Jul 3, 2009 + * Class::MOP::Class + * Class::MOP::Class::Immutable::Trait + - Made the Trait act like a role with a bunch of "around" + modifiers, rather than sticking it in the inheritance + hierarchy. This fixes various problems that caused with + metaclass compatibility, which broke Fey::ORM. + + * Class::MOP::Method + - Allow a blessed code reference as the method body. Fixes a + problem interaction with MooseX::Types. (ash) + + * Class::MOP::Instance + - add inline version of rebless_instance_structure. (doy) + - change inline_slot_access to use single quotes (gphat) + +0.88 Tue, Jun 23, 2009 + * Class::MOP::Class + - Moved the __INSTANCE__ parameter to _construct_instance from + Moose to here. (doy) + - Fixed some issues involving metaclasses of metaclasses and + immutability. (doy) + +0.87 Sun, Jun 21, 2009 + * Various + - Made sure to always local-ize $@ and $SIG{__DIE__} before + calling an eval. Fixes RT #45973. + + * Class::MOP::Class + - Synced docs about immutability with the current reality (which + changed back in 0.82_01) + - Removed the immutable_transformer method, which had been + returning undef since 0.82_01 anyway. + + * Tests + - Got rid of tests which needed Moose and improved testing of + constructor/destructor inlining warnings. Fixes RT #47119. + +0.86 Tue, Jun 16, 2009 + * Class::MOP::Class + - If you redefined a subroutine at runtime and then wrapped it + with a method modifier, the modifier could in some cases wrap + the original version of the subroutine. Fixes RT #46957. + + * Class::MOP::Class + - make_immutable issues a warning instead of overriding an + existing DESTROY method (Dylan William Hardison). Fixes RT + #46854. + +0.85 Sat, Jun 6, 2009 + * Class::MOP::Attribute + - Allow default values to be Class::MOP::Methods. (Florian + Ragwitz) + - Test the above. (Rhesa Rozendaal) + - Tweak original commit so the intent matches the accepted + behavior (Nicholas Perez) + + * Class::MOP + - Localize $SIG{__DIE__} inside _try_load_one_class (Sartak) + + * Class::MOP::Class + - Add direct_subclasses method (Sartak) + - Tests for subclasses and direct_subclasses (Sartak) + - subname is no longer used unconditionally in add_method, but + only if the code reference's name is '__ANON__' (nothingmuch) + - Add a hook for _superclasses_updated (Sartak) + + * Class::MOP::Method + - Remove long, old warning about possibly outdated modules + (Sartak) + +0.84 Tue, May 12, 2009 + * Makefile.PL + - Depend on Text::Exception 0.27 to avoid failing tests ond old + versions (rafl) + + * Class::MOP + - Made is_class_loaded a little stricter. It was reporting that + a class was loaded if it merely had an @ISA variable in its + stash. Now it checks that the @ISA var has elements in it. + - Deprecate in_global_destruction and subname re-exporting + (perigrin & Sartak) + + * Class::MOP::Class + - Explicitly use Devel::GlobalDestruction and Sub::Name + (perigrin) + + * Class::MOP::Package + - Disable prototype mismatch warnings for add_package_symbol. + (Florian Ragwitz) + * Tests + - Add test for finding methods from $meta->name->meta before immutable, + (t0m) + +0.83 Mon, April 27, 2009 + * Class::MOP::Class + - Fix segfault when calling get_method_map on a metaclass for an empty + package (doy) + +0.82_02 Fri, April 24, 2009 + * Class::MOP::Method::Inlined + - Don't inline if the expected method is not defined at all (happens with + e.g. Moose::Object::_new is the expected method due to an overridden + name) + * Tests + - Some tests were trying to load Class::MOP::Immutable, which + was removed in 0.82_01. + +0.82_01 Thu, April 23, 2009 + * Class::MOP::Immutable (and others) + - Refactor the immutability system to use a pre-defined class + for the immutable metaclass of Class::MOP::Class::Immutable::$class + - Rather than generating methods into this class every time, use + a Trait (basic mixin) to supply the cached methods + - Remove the hack that returns the mutable metaclass for + metacircularity in order to provide consistent meta-metaclasses + for the Moose compatibility handling code + (mst broke it, nothingmuch fixed it) + +0.82 Mon, April 20, 2009 + * Various + - The deprecation wrappers for some renamed methods were not + passing arguments to the new method. (nothingmuch) + + * Class::MOP::Immutable + - Warn during immutablization if the local class provides its own + constructor, to parallel the warning in Moose when a superclass + provides its own constructor (doy) + +0.81 Tue, April 7, 2009 + * Class::MOP + * Class::MOP::Class + * Class::MOP::Instance + * Class::MOP::Attribute + * Class::MOP::Method::Accessor + * Class::MOP::Method::Constructor + - Include stack traces in the deprecation warnings introduced in + 0.80_01. (Florian Ragwitz) + + * MOP.xs + - Avoid c compiler warnings by declaring some unused function + arguments. (Florian Ragwitz) + +0.80_01 Sun, April 5, 2009 + * Makefile.PL + - Make sure to preserve any compiler flags already defined in + Config.pm. Patch by Vincent Pit. RT #44739. + + * Many methods have been renamed with a leading underscore, and a + few have been deprecated entirely. The methods with a leading + underscore are considered "internals only". People writing + subclasses or extensions to Class::MOP should feel free to + override them, but they are not for "public" use. + + - Class::MOP::Class + - construct_class_instance => _construct_class_instance (use new_object) + - construct_instance => _construct_instance (use new_object) + - check_metaclass_compatibility => _check_metaclass_compatibility + - create_meta_instance => _create_meta_instance (use get_meta_instance) + - clone_instance => _clone_instance (use clone_object) + - compute_all_applicable_methods is deprecated, use get_all_methods + - compute_all_applicable_attributes is deprecated, use get_all_attributes + + - Class::MOP::Instance + - bless_instance_structure is deprecated and will be removed + in a future release + + - Class::MOP::Module + - create has been renamed to _instantiate_module. This method + does not construct an object, it evals some code that + creates the relevant package in Perl's symbol table. + + - Class::MOP::Method::Accessor + - initialize_body => _initialize_body (this is always called + when an object is constructed) + - /(generate_.*_method(?:_inline)?)/ => '_' . $1 + + - Class::MOP::Method::Constructor + - initialize_body => _initialize_body (this is always called + when an object is constructed) + - /(generate_constructor_method(?:_inline)?)/ => '_' . $1 + - attributes => _attributes + - meta_instance => _meta_instance + +0.80 Wed, April 1, 2009 + * Class::MOP::* + - Call user_class->meta in fewer places, with the eventual goal + of allowing the user to rename or exclude ->meta + altogether. Instead uses Class::MOP::class_of. (Sartak) + + * Class::MOP + - New class_of function that should be used to retrieve a + metaclass. This is unlike get_metaclass_by_name in that it + accepts instances, not just class names. (Sartak) + + * Class::MOP + - load_first_existing_class didn't actually load the first + existing class; instead, it loaded the first existing and + compiling class. It now throws an error if a class exists (in + @INC) but fails to compile. (hdp) + + * Class::MOP + * Class::MOP::Class + - we had some semi-buggy code that purported to provide a + HAS_ISAREV based on whether mro had get_isarev (due to an + oversight, it always returned 1). Since mro and MRO::Compat + have always had get_isarev, HAS_ISAREV was pointless. This + insight simplified the subclasses method by deleting the + pure-perl fallback. HAS_ISAREV is now deprecated. (Sartak) + +0.79 Fri, March 29, 2009 + * No changes from 0.78_02. + +0.78_02 Thu, March 26, 2009 + * Class::MOP::Class + * Class::MOP::Immutable + - A big backwards-incompatible refactoring of the Immutable API, + and the make_immutable/make_mutable pieces of the Class + API. The core __PACKAGE__->meta->make_immutable API remains + the same, however, so this should only affect the most + guts-digging code. + + * XS code + - The XS code used a macro, XSPROTO, that's only in 5.10.x. This + has been fixed to be backwards compatible with 5.8.x. + + * Class::MOP::Class + - Add a hook for rebless_instance_away (Sartak) + - Use blessed instead of ref to get an instance's class name + in rebless_instance. (Sartak) + +0.78_01 Wed, March 18, 2009 + * Class::MOP::* + - Revised and reorganized all of the API documentation. All + classes now have (more or less) complete API documentation. + + * Class::MOP::Class + * Class::MOP::Instance + - Reblessing into a package that supports overloading wasn't + properly adding overload magic to the object due to a bug + in (at least) 5.8.8. We now use $_[1] directly which seems + to set the magic properly. (Sartak) + + * Class::MOP::Attribute + - The process_accessors method is now private. A public alias + exists (and will stick around for a few releases), but it + warns that calling the public method is deprecated. + + * Class::MOP::Method::Generated + - Removed the new and _new methods, since this is an abstract + base class, and all existing subclasses implement their own + constructors. + + * MOP.xs + - Stop is_class_loaded from thinking a class is loaded if it + only has an empty GV (Florian Ragwitz). + - Add a test for this (Yappo). + - Refactor get_all_package_symbols to allow short-circuiting + (Florian Ragwitz). + - Use this in is_class_loaded (Florian Ragwitz). + - Stop segfaulting when trying to get the name from a sub that's + still being compiled (Florian Ragwitz). + - Add tests for this (Florian Ragwitz). + - Prefix all public symbols with "mop_" (Florian Ragwitz). + - Clean up and simplify prehashing of hash keys (Florian Ragwitz). + - Simplify creating simple xs reader methods (Florian Ragwitz). + - Make everything compile with c++ compilers (Florian Ragwitz). + - Upgrade ppport.h from 3.14 to 3.17 (Florian Ragwitz). + + * Tests + - Remove optional test plans for tests depending on Sub::Name as + we have a hard dependency on Sub::Name anyway (Florian Ragwitz). + + * Makefile.PL + - Rebuild all c code if mop.h has changed (Florian Ragwitz) + +0.78 Mon, February 23, 2009 + * No changes from 0.77_01 + +0.77_01 Sun, February 22, 2009 + * Everything + - This package now requires its XS components. Not using + Sub::Name lead to different behavior and bugginess in the pure + Perl version of the code. A Moose test would fail when run + against the pure Perl version of this code. + + * Class::MOP::Instance + - The inline_* methods now quote attribute names themselves, and + don't expect to receive a quoted value. + + +0.77 Sat, February 14, 2009 + * MOP.xs + - Avoid assertion errors on debugging perls in is_class_loaded + (Florian Ragwitz) + + * Class::MOP + - Fixed various corner cases where is_class_loaded incorrectly + returned true for a class that wasn't really loaded. (Dave + Rolsky) + + * Class::MOP::Class + - Add get_all_method_names (Sartak) + - Add a wrapped_method_metaclass attribute (Florian Ragwitz) + + * Class::MOP::Package + - Disable deprecated get_all_package_symbols in list + context. (Florian Ragwitz) + + * Makefile.PL + - Make sure we generate a BSD-compatible Makefile (Florian + Ragwitz) + + * Class::MOP::Class + - The misspelled "check_metaclass_compatability" method we've + kept around for backwards compat_i_bility will be removed in a + near future release. You've been warned. + +0.76 Thu, January 22, 2009 + * Class::MOP::Method::Generated + - Added new private methods to support code generation, which + are being used by Moose and can be used by MooseX + authors. (mst) + - Generated methods are now generated with a #line directive + reflecting the source of the generated method. (nothingmuch) + + * Class::MOP::Class + - Clarified documentation of methods that return + Class::MOP::Method objects. (doy) + + * Class::MOP + - Clarified documentation of the metaclass cache methods. (Sartak) + + * Tests + - Add test showing how the xs Class::MOP::is_class_loaded can + be made to operate differently to the pure perl version (t0m) + +0.75 Wed, December 31, 2008 + * Class::MOP::Class + - A class that was made immutable and then mutable could end up + sharing an immutable transformer object + (Class::MOP::Immutable) with other classes, leading to all + sorts of odd bugs. Reported by t0m. (Dave Rolsky) + +0.74 Tue, December 25, 2008 + * MOP.xs + - Add an xs implementation of Class::MOP::is_class_loaded (closes + RT#41862). Based on a patch by Goro Fuji. (Florian Ragwitz) + - Changed internals to make prehashing of hash keys easier and less + error-prone. (Florian Ragwitz) + * Class::MOP::Class + - Fix documentation to show that around modifiers happen on both + sides of the modified method. (Dave Rolsky) + +0.73 Tue, December 16, 2008 + * MOP.xs + - Don't use Perl_mro_meta_init. It's not part of the public perl + api. Fixes failures to build on Win32 (RT #41750). (Florian + Ragwitz) + * t/082_get_code_info.t + - Add $^P &= ~0x200; (per Ovid's suggestion) in order to not + munger anonymous subs when under -d and so making the tests + succeed in that case. + +0.72 Mon, December 8, 2008 + * Class::MOP::Package + - Pass options to _new, so subclass' attributes can be + initialized (Sartak) + * Class::MOP::Method + - In the docs, indicate that package_name and name are required + when calling ->wrap (Stefan O'Rear) + +0.71_02 Fri, December 5, 2008 + * Class::MOP::Immutable + - Added a new attribute, inlined_constructor, which is true if + the constructor was inlined. + * Class::MOP::Package + - Make get_all_package_symbols return a hash ref in scalar + context and deprecate calling it in list context with a + warning. (Florian Ragwitz) + * MOP.xs + - Various improvements and refactoring, making things more robust and + easier to maintain. (Florian Ragwitz) + +0.71_01 Wed, December 3, 2008 + * Class::MOP::Method + - Add an "execute" method to invoke the body so + we can avoid using the coderef overload (Sartak) + * Class::MOP::Immutable + - When we memoize methods, get their results lazily + to remove some compile-time cost (Sartak) + - Small speedup from eliminating several method + calls (Sartak) + * Class::MOP::Class + - Some small internal tweaks to try to reduce the number of + times we call get_method_map when bootstrapping the MOP. This + might make loading Class::MOP (and Moose) a little + faster. (Dave Rolsky) + - Implemented an optional XS version of get_method_map. Mostly + taken from a patch by Goro Fuji (rt.cpan.org #41080), with + help form Florian Ragwitz. (Dave Rolsky) + - Make the behaviour of of get_all_package_symbols (and + therefore get_method_map) consistent for stub methods. Report + and test by Goro Fuji (rt.cpan.org #41255). (Florian Ragwitz) + +0.71 Wed November 26, 2008 + * Class::MOP::Class + * Class::MOP::Module + - Actual package creation has moved upward from + Class to Module so that Moose roles can share + the code (Sartak) + +0.70_01 Mon, November 19, 2008 + * Class::MOP + - Fixes for failures with blead (Florian Ragwitz) + - Silenced compiler warnings (Florian Ragwitz) + +0.70 Fri, November 14, 2008 + * Class::MOP + - Fixed an odd corner case where the XS version of + get_all_package_symbols could cause a segfault. This only + happened with inlined constants in Perl 5.10.0 (Florian + Ragwitz) + +0.69 Fri, November 7, 2008 + * Class::MOP::Method::Wrapped + - Added introspection methods for method modifiers (Dave Rolsky) + + +0.68 Fri October 24, 2008 + * Class::MOP + - Make load_class require by file name instead of module name. + This stops confusing error messages when loading '__PACKAGE__'. + (Florian Ragwitz) + - Add load_one_class_of function to enable you to load one of a + list of classes, rather than having to call load_class multiple + times in an eval. (t0m) + +0.67 Tue October 14, 2008 + * Class::MOP::Class + - Call a method on the class after setting the superclass list + so that we can get Perl to detect cycles before MRO::Compat + spirals into an infinite loop (sartak) + - Reported by Schwern, [rt.cpan.org #39001] + - In create(), pass unused options on to initialize() + - added test for this + +0.66 Sat September 20, 2008 + !! This release has an incompatible change regarding !! + introspection of a class's method with Class::MOP::Class !! + + * Tests and XS + - We (us maintainers) now run all tests with XS and then without + XS, which should help us catch skew between the XS/pure Perl + code. (Dave Rolsky) + + * Class::MOP::Class + ! The alias_method method has been deprecated. It now simply + calls add_method instead. There is no distinction between + aliased methods and "real" methods. + + This means that methods added via alias_method now show up as + part of the class's method list/map. This is a backwards + incompatible change, but seems unlikely to break any + code. Famous last words. (Dave Rolsky) + + * Class::MOP::Class + - Fixed the spelling of "compatibility", but we still have a + "check_metaclass_compatability" method for backwards + compatibility. + +0.65 Mon September 1, 2008 + For those not following the series of dev releases, the changes + from 0.64 from 0.65 can mostly be summed up as a lot performance + improvements by nothingmuch, including new optional XS versions of + some methods. Also, Class::MOP now works _without_ any XS modules, + for sad systems without a compiler. + + * Class::MOP::Method + - Added name and package_name XS accessors, and make sure all + the XS and Perl versions work the same way. (Dave Rolsky) + + * MOP.xs + - The XS versions of various methods just returned undef when + called class methods, rather than dying like the pure Perl + versions. (Dave Rolsky) + +0.64_07 Fri August 29, 2008 + * Class::MOP + - Silenced warnings that managed to break Moose tests when XS + was loaded. (Dave Rolsky) + - Some XS versions of methods were ignored because of typos in + MOP.xs. (Dave Rolsky) + +0.64_06 Mon August 25, 2008 + * Class::MOP (MOP.xs) + - Another MS VC++ fix, cannot declare a variable in the middle + of a scope (Taro Nishino). + +0.64_05 Sun August 24, 2008 + * Class::MOP + - None of the dev releases actually loaded the XS properly, but + we silently fell back to the pure Perl version of the + code. (Dave Rolsky) + + * Class::MOP (MOP.xs) + - Replaced some code that used functions not available on Visual + C++ with some Perl XS API bits (Dave Rolsky). + +0.64_04 Sat August 23, 2008 + * Class::MOP::Class + - Workaround a bug in 5.8.1's goto sub (nothingmuch) + + * pod.t and pod_coveraget.t + - These are no longer shipped with the tarball because of bogus + failures from CPAN testers. (Dave Rolsky) + +0.64_03 Thu August 21, 2008 + * Class::MOP::Package + - Some (legit) code was misparsed by earlier 5.8.x + releases. (nothingmuch) + + * Class::MOP + - Fix a constant in void context warning (nothingmuch) + +0.64_02 Thu August 21, 2008 + * Makefile.PL and Class::MOP + - Explicitly require Perl 5.8.0+ (Dave Rolsky) + + * Makefile.PL + - Add missing prereqs that got lost in the switch away from + Module::Install. + + * Class::MOP::Instance + - New method - get_all_attributes (nothingmuch) + +0.64_01 Wed August 20, 2008 + * Makefile.PL + - We now check to see if you have a compiler. If you don't, the + module installs without some XS bits, but will work the same + as with XS. This should make it easier to install on platforms + without a compiler (like Windows). (Dave Rolsky) + + * many modules + - Perl 6 style attribute naming replaced with sane style ('methods', not + '%!methods'). These changes should not impact any existing API uses. + (nothingmuch). + + * many modules + - Quite a number of optimizations based on profiling, including + allowing constructors to take hash references instead of + hashes, duplicating some frequently used code in XS, and + making constructors immutable. These changes should not impact + any existing API uses. (nothingmuch) + + * Many modules + - Constructors now respect the meta attributes of their subclasses, + facilitating MOP extensibility. More related changes will happen in the + next several releases. (nothingmuch) + + * Class::MOP::Class + - New method - get_all_methods, replaces the deprecated + compute_all_applicable_methods. get_all_attributes provided for + consistency (nothingmuch) + - New method - wrap_method was refactored out of get_method_map + (nothingmuch) + - New API for meta instance invalidation - invalidate_meta_instance, + invalidate_meta_instances, add_dependent_meta_instance, + remove_dependent_meta_instance, called automatically when attribute + definitions change and allows notification of dependent subclasses. + (nothingmuch) + +0.64 Sun August 3, 2008 + * Class::MOP::Immutable + - fixing subtle edge case in immutable when you + call ->meta (stevan) + - clean up option processing (nothingmuch) + + * Class::MOP::Instance + - inlined initialize slot didn't match + non-inlined (nothingmuch) + +0.63 Mon July 7, 2008 + * Class::MOP + - load_class will initialize a metaclass even if + the class is already loaded (sartak) + - load_class now returns the metaclass instance + instead of just 1 (sartak) + + * elsewhere + - better error messages (sartak and Dave Rolsky) + +0.62 Wed June 18, 2008 + - in is_class_loaded, recognize scalar references (as opposed to globs) in + the symbol table as methods (these are optimized constant subs) + +0.61 Fri. June 13, 2008 + - Okay, lets give this another try and see if PAUSE + recognizes it correct this time. + +0.60 Thurs. Jun 12, 2008 + - Fixed a version number issue by bumping all modules + to 0.60. + +0.59 Thurs. Jun 12, 2008 + !! Several fixes resulting in yet another 25-30% speedup !! + + * Class::MOP::Class + - now stores the instance of the instance + metaclass to avoid needless recomputation + and deletes it when the cache is blown + - introduce methods to query Class::MOP::Class for + the options used to make it immutable as well as + the proper immutable transformer. (groditi) + + * Class::MOP::Package + - {add, has, get, remove}_package_symbol all + now accept a HASH ref argument as well as the + string. All internal usages now use the HASH + ref version. + + * Class::MOP + - MOP.xs does sanity checks on the coderef + to avoid a segfault + - is_class_loaded check now uses code that + was improved in Moose's ClassName type + check (Sartak) + - nonsensical (undef, empty, reference) class + names now throw a more direct error in + load_class (Sartak) + - tests for this and other aspects of + load_class (Sartak) + + * Class::MOP + Class::MOP::Class + Class::MOP::Method + Class::MOP::Method::Wrapped + Class::MOP::Attribute + - switched usage of reftype to ref because + it is much faster + +0.58 Thurs. May 29, 2008 + (late night release engineering)-- + + - fixing the version is META.yml, no functional + changes in this release + +0.57 Wed. May 28, 2008 + !! Several speedups resulting in 20-25% speedups !! + || (thanks to konobi, groditi, mst & CataMoose) !! + + * Class::MOP::Class + - made get_method_map use list_all_package_symbols + instead of manually grabbing each symbol + - streamlining &initialize somewhat, since it gets + called so much + + * Class::MOP::Package + - made {get, has}_package_symbol not call + &namespace so much + - inlining a few calls to &name with + direct HASH access key access + - added get_all_package_symbols to fetch + a HASH of items based on a type filter + similar to list_all_package_symbols + - added tests for this + + * Class::MOP::Method + Class::MOP::Method::Constructor + Class::MOP::Method::Generated + Class::MOP::Method::Accessor + - added more descriptive error message to help + keep people from wasting time tracking an error + that is easily fixed by upgrading. + + * Class::MOP::Immutable + - Don't inline a destructor unless the user actually + needs one + - added tests for this + +0.56 Saturday, May 24, 2008 + * Class::MOP + - we now get the &check_package_cache_flag + function from MRO::Compat + - All XS based functionality now has a + Pure Perl alternative + - the CLASS_MOP_NO_XS environment variable + can now be used to force non-XS versions + to always be used + + * Class::MOP::Attribute + - add has_read_method and has_write_method + - get_{read,write}_method_ref now wraps the + anon-sub ref in the method metaclass when + possible + - added tests for this + + * Class::MOP::Immutable + - added the ability to "wrap" methods when + making the class immutable + + * Class::MOP::Class + - now handling the edge case of ->meta->identifier + dying by wrapping add_package_symbol to specifically + allow for it to work. + - added tests for this + + * Class::MOP::Attribute + Class::MOP::Class + Class::MOP::Immutable + - any time a method meta object is constructed + we make sure to pass the correct package and + method name information + + * Class::MOP::Method + Class::MOP::Method::Wrapped + Class::MOP::Method::Generated + Class::MOP::Method::Accessor + Class::MOP::Method::Consructor + - the &wrap constructor method now requires that a + 'package_name' and 'name' attribute are passed. This + is to help support the no-XS version, and will + throw an error if these are not supplied. + - all these classes are now bootstrapped properly + and now store the package_name and name attributes + correctly as well + + ~ Build.PL has been removed since the + Module::Install support has been removed + +0.55 Mon. April 28, 2008 + - All classes now have proper C3 MRO support + - added MRO::Compat as a dependency to allow + for the C3 MRO support to Just Work in all + perl versions + + * Class::MOP::Class + - rebless_instance now returns the instance + it has just blessed, this is mostly to + facilitate chaining + - set the attr correctly in rebless_instance + when it has no init_arg + - tweaked &linear_isa and &class_precedence_list + to support c3 classes. + +0.54 Fri. March, 14, 2008 + * Class::MOP + metaclass.pm + - making sure that load_class never gets + passed a value from @_ or $_ to squash + Ovid's bug (http://use.perl.org/~Ovid/journal/35763) + + * Class::MOP::Class + - make_{immutable,mutable} now return 1 + (cause Sartak asked) + - improved error handling in ->create method + - rebless_instance now takes extra params which + will be used to populate values + - added tests for this + + * Class::MOP::Object + - localizing the Data::Dumper configurations so + that it does not pollute others (RT #33509) + + * Class::MOP::Class + Class::MOP::Package + Class::MOP::Module + Class::MOP::Method + Class::MOP::Attribute + - these classes no longer define their own ->meta, + but instead just inherit from Class::MOP::Object + + * Class::MOP::Instance + Class::MOP::Immutable + - these classes now inherit from Class::MOP::Object + + * t/ + - fixed the filename length on several + test files so we install on VMS better + (RT #32295) + - fixed incorrect use of catdir when it + should be catfile (RT #32385) + +0.53 Thurs. Feb. 14, 1008 + ~~ several doc. fixes and updates ~~ + + * Class::MOP::Class + Class::MOP::Method::Constructor + Class::MOP::Attribute + - making init_arg accept an undefined value + to indicate that no constructor args can + be passed (thanks to nothingmuch) + - added tests for this + - added attribute initializer attribute (rjbs) + + * Class::MOP. + - making this use the new init_arg => undef + feature instead of the silly hack from + before (thanks to nothingmuch) + +0.52 Tues. Jan. 22, 2008 + * Class::MOP::Class + - fixed bug in rebless_instance + (discovered by ash) + + * Class::MOP::Method::Constructor + - removed assumptions about the existence of + a &meta method + +0.51 Mon. Jan. 14, 2008 + ~~~ some misc. doc. fixes ~~~ + ~~ updated copyright dates ~~ + + * Class::MOP + - now sets the IS_RUNNING_ON_5_10 + constant so that we can take advantage + of some of the nice bits of 5.10 + + * Class::MOP::Class + - uses the IS_RUNNING_ON_5_10 flag to + optimize the &linearized_isa method + and avoid the hack/check for circular + inheritence in &class_precedence_list + - added rebless_instance method (Sartak) + - added tests for this + + * Class::MOP::Immutable + - the immutable class now keeps track of + the transformer which immutablized it + + * Class::MOP::Instance + - added rebless_instance_structure method (Sartak) + - added tests for this + +0.50 Fri. Dec. 21, 2007 + * Class::MOP::Class + - fixed bug in immutable to make sure that + transformation arguments are saved + correctly (mst) + - added tests for this + + * Class::MOP::Immutable + - fixed a bug (see above) + + * Class::MOP::Attribute + - some doc updates + +0.49 Fri. Dec. 14, 2007 + !! Class::MOP now loads 2 x faster !! + !! with XS speedups (thanks konobi) !! + + * Class::MOP + - removed the dependency on B + - added two XS functions (thanks konobi) + - get_code_info($code) which replaces all + the B fiddling we were doing with + faster/leaner XS level fiddling + - check_package_cache_flag($pkg_name) which + returns the PL_sub_generation variable to + be used to help manage method caching. + + NOTE: + In 5.10 or greater this will actually + use the mro::get_pkg_gen instead to give + even more accurate caching information. + blblack++ for that stuff :) + + * Class::MOP::Class + - added the &subclasses method (thanks rlb) + - added the update_package_cache_flag and + reset_package_cache_flag which help keep + track of when we need to re-fetch the + method map. + - Several small improvements to take advantage + of the new method map caching features + +0.48 Mon. Nov. 26, 2007 + * Class::MOP::Attribute + - fixed get_read/write_method to handle the + HASH ref case, which makes the + get_read/write_method_ref handle it too. + - added more tests for this + +0.47 Sat. Nov. 24, 2007 + * Class::MOP::Attribute + - fixed misspelling in get_write_method_ref + - added more tests for this + +0.46 Fri. Nov. 23, 2007 + * Class::MOP::Class + - added the linearized_isa method instead of constantly + pruning duplicate classes (this will be even more + useful in the 5.10-compat version coming soon) + + * Class::MOP::Attribute + - added the get_read_method_ref and get_write_method_ref + methods which allow you to retrieve a CODE ref which + can always be used to read or write an attribute. + +0.45 Thurs. Nov. 13, 2007 + * Class::MOP::Attribute + - Fix error message on confess (groditi) + +0.44 Thurs. Nov. 13, 2007 + - Apparently I didn't make dist correctly (groditi) + +0.43 Thurs. Nov. 13, 2007 + * Class::MOP + - Add support for the 'builder' attribute (groditi) + + * Class::MOP::Class + - optimise metaclass-already-exists check in + construct_class_instance (groditi) + - duplicate check into initialize to save a + call through (groditi) + + * Class::MOP::Attribute + - Add support for the 'builder' attribute (groditi) + - Make predicates check for the existence of a value, not whether + it is defined (groditi) + + * Class::MOP::Instance + - Make predicates check for the existence of a value, not whether + it is defined (groditi) + + * Class::MOP::Method::Accessor + - made this a subclass of Class::MOP::Method::Generated + - removed the relevant attributes + + * Class::MOP::Method::Constructor + - fixed the cached values we had to be more sane + - made this a subclass of Class::MOP::Method::Generated + - fixed generated constructor so it properly handles + subclasses now. + - added tests for this + - added the option to allow for both inlined and + non-inlined constructors. + - Update inlined methods for builder and predicate changes (groditi) + + * Class::MOP::Method::Generated + - added this class as an abstract base for the + Class::MOP::Method::{Constructor,Accessor} classes + - added tests for this + + *t/ + - Alter tests (005, 014 020, 021) for new builder addition (groditi) + - Tests for new predicate behavior (and corrections to old tests) (groditi) + + *examples/ + - Update ArrayRef based class example to work with predicate changes + +0.42 Mon. July 16, 2007 + !!! Horray for mst, he fixed it !!! + + * Class::MOP::Package + - alter symbol table handling to deal with 5.8.x and 5.9.x + + * t/ + - Get rid of the crappy workaround from 0.40/41 + +0.41 Sun. July 15, 2007 + * t/ + Arghh!!! My TODO test didn't work, so I handle + it manually now so that people can use this + with 5.9.5/bleadperl without issue. + +0.40 Tues, July 3, 2007 + * t/ + ~ marked a test in 003_methods.t as TODO + for perl 5.9.5 (this test is irrelvant to + the module functioning on 5.9.5 for the most + part anyway) + +0.39 Mon. June 18, 2007 + * Class::MOP::Immutable + - added make_metaclass_mutable + docs (groditi) + - removed unused variable + - added create_immutable_transformer + necessary for sane overloading of immutable behavior + - tests for this (groditi) + + * Class::MOP::Class + - Immutability can now be undone, + added make_mutable + tests + docs (groditi) + - Massive changes to the way Immutable is done + for details see comments next to make_immutable + This fixes a bug where custom metaclasses broke + when made immutable. We are now keeping one immutable + metaclass instance per metaclass instead of just one + to prevent isa hierarchy corruption. Memory use will go + up, but I suspect it will be neglible. + - New tests added for this behavior. (groditi) + +0.38 Thurs. May 31, 2007 + ~~ More documentation updates ~~ + + * Class::MOP::Package + - we now deal with stub methods properly + - added tests for this + - fixed some tests failing on 5.9.5 (thanks blblack) + + * Class::MOP::Attribute + - added get_read_method and get_write_method + thanks to groditi for this code, tests + and docs. + - added tests and POD for this + + * Class::MOP::Class + - fixed RT issue #27329, clone object now + handles undef values correctly. + - added tests for this + - Corrected anon-class handling so that they + will not get reaped when instances still + exist which need to reference them. This is + the correct behavior, hopefully this is an + obscure enough feature that there are not too + many work arounds out in the wild. + - added tests for this by groditi + - updated docs to explain this + + * metaclass + - load custom metaclasses automatically (thanks groditi) + - added tests for this behavior + +0.37 Sat. March 10, 2007 + ~~ Many, many documentation updates ~~ + + * Class::MOP + - added &load_class and &is_class_loaded + - added tests and docs for these + + * Class::MOP::Attribute + - default now checks the instance with defined to + avoid setting off bool-overloads (found by Carl Franks) + +0.37_002 + * /t + - bad name in a test, causing meaningless failuress. + No other changes. + +0.37_001 + + ~~ GLOBAL CHANGES ~~ + - All attribute names are now consistent and follow Perl 6 + style (prefixed with the sigil, and ! as the twigil for + private attrs). This should not affect any code, unless + you broke encapsulation, in which case, it is your problem + anyway. + + !! Class::MOP::Class::Immutable has been removed + + * Class::MOP::Method::Constructor + - this has been moved out of Class::MOP::Class::Immutable + and is a proper subclass of Class::MOP::Method now. + + * Class::MOP::Class + - this module now uses Class::MOP::Immutable for the + immutable transformation instead of + Class::MOP::Class::Immutable. + + + Class::MOP::Immutable + - this module now controls the transformation from a mutable + to an immutable version of the class. Docs for this will + be coming eventually. + + +0.36 Sun. Nov. 5, 2006 + * Class::MOP::Class + - added a few 'no warnings' lines to keep annoying + (and meaningless) warnings from chirping during + global destruction. + + * Class::MOP + - some more bootstrapping is now done on the new + classes + + * Class::MOP::Class::Immutable + *** API CHANGE *** + - constructor generation is now handled by + the Class::MOP::Method::Constructor class + + * Class::MOP::Method::Constructor + - created this to handle constructor generation + in Class::MOP::Class::Immutable + + * Class::MOP::Attribute + *** API CHANGE *** + - attributes now delegate to the + Class::MOP::Method::Accessor to generate + accessors + + * Class::MOP::Method::Accessor + - all accessor generation functions from + Class::MOP::Attribute have been moved here + +0.35 Sat. Sept. 30, 2006 + + * scripts/class_browser.pl + - initial prototype of a class browser, more + on this to come. Comments and patches are + very much welcome. + + * Class::MOP + - All Class::MOP::* accessors are no longer + re-generated in the bootstrap, instead + they are aliased from the originals + - fixed tests to reflect + - added Class::MOP::Method (and its subclasses) + to the bootstrap + - adjusted tests for this + - added the Class::MOP::Instance attributes + to the bootstrap + + * Class::MOP::Method + *** API CHANGE *** + - methods are no longer blessed CODE refs + but are actual objects which can be CODE-ified + - adjusted tests to compensate + - adjusted docs for this + + * Class::MOP::Class + - changed how methods are dealt with to + encapsulate most of the work into the + &get_method_map method + - made several adjustments for the change + in Class::MOP::Method + - &add_attribute now checks if you are adding + a duplicate name, and properly removes the + old one before installing the new one + - added tests for this + - adjusted docs for this + + * Class::MOP::Class::Immutable + - added caching of &get_method_map + - fixed issue with &get_package_symbol + - cleaned up the methods that die (patch by David Wheeler) + + * Class::MOP::Package + - added filtering capabilities to + &list_all_package_symbols + +0.34 Sat. Aug. 26, 2006 + * Class::MOP::Class + - added the %:methods attribute, which like + the $:version and such just actually goes + to the symbol table to get it's stuff. + However, it makes the MOP more complete. + ** API CHANGE ** + - The &create method now requires that all + but the package name now is passed in as + named parameters. See docs for more info. + - updated docs and tests for this + + * Class::MOP::Object + - added &dump method to easily Data::Dumper + an object + + * Class::MOP + - cleaned up the initialization of attributes + which do not store things in the instance + - added the %:methods attribute definition to + the bootstrap + + ~ lots of misc. test cleanup + +0.33 Sat. Aug. 19, 2006 + * Class::MOP::Class + - moved the metaclass cache out of here + and it is now in Class::MOP itself. + + * Class::MOP + - moved all the metaclass cache stuff here + - fixed all tests for this + + * Class::MOP::Attribute + - reference values (other than CODE refs) + are no longer allowed for defaults + - added tests for this + + * Class::MOP::Package + - fixed an issue with perl 5.8.1 and how it deals + with symbol tables. The namespace hash is now + always reloaded from the symbol table. + + ~ lots of misc. documentation cleanup + +0.32 Sat. Aug. 12, 2006 + + added Class::MOP::Object so that the + metamodel is more complete (and closer + to what Perl 6 will probably be). + + * Class::MOP::Package + - refactored entire class, this is now + the primary gateway between the metaclass + and the Perl 5 symbol table + - added many tests for this + - this class is now a subclass of + Class::MOP::Object + - added some tests to reflect this + + * Class::MOP::Class + - refactored all symbol table access to + use Class::MOP::Package methods instead + + * Class::MOP::Module + - adding the $:version attribute in the bootstrap + so that Module has a version as an attribute + - see comment in Class::MOP for details + - added the $:authority attribute to this module + as well as an &identifier method, to bring us + ever closer to Perl 6 goodness + - I have added $AUTHORITY to all the modules + - added tests for this + + * Class::MOP::Instance + - added &deinitialize_slot for removing slots + from an instance + - added tests for this + + * Class::MOP::Attribute + - added support for &deinitialize_slot for removing + slots from an instance + - added tests for this + +0.31 Sat. July 15, 2006 + + * Class::MOP::Class + - added &find_method_by_name to locate a method + anywhere within the class hierarchy + + * Class::MOP::Attribute + - added &set_value and &get_value for getting + the value of the attribute for a particular + instance. + +0.30 Wed. July 5, 2006 + --------------------------------------- + This is the first version of Class::MOP + to introduce the immutable features which + will be used for optimizating the MOP. + This support should still be considered + experimental, but moving towards stability. + --------------------------------------- + + * Created Class::MOP::Class::Immutable + + * Created the Class::MOP::Package and + Class::MOP::Module classes to more + closely conform to Perl 6's meta-model + + * Class::MOP::Class + - now inherits from Class::MOP::Module + - several methods moved to ::Module and + ::Package and now inherited + - added tests for this + + * Class::MOP::Instance + - added an is_inlinable method to allow other + classes to check before they attempt to optimize. + - added an inline_create_instance to inline + instance creation (of course) + + ** API CHANGE ** + - the Class::MOP::Class::*_package_variable + methods are all now methods of Class::MOP::Package + and called *_package_symbol instead. This is + because they are now more general purpose symbol + table manipulation methods. + +0.29_02 Thurs. June 22, 2006 + ++ DEVELOPER RELEASE ++ + * Class::MOP::Class + - small change in &create so that it behaves + properly when inherited + - small fix to &clone_instance + +0.29_01 Fri. May 12, 2006 + ++ DEVELOPER RELEASE ++ + - This release works in combination with + Moose 0.09_01, it is a developer release + because it introduces a new instance + sub-protocol and has not yet been + optimized. + + * Class::MOP::Class + - anon-classes are now properly garbage collected + - added tests for this + - improved method modifier wrapping + + * Class::MOP::Instance + - added new instance protocol + - added tests for this + - changed all relevant modules and examples + - Class::MOP::Class + - Class::MOP::Attribute + - examples/* + + * metaclass + - you no longer need to specify the metaclass + itself, if it is not there, Class::MOP::Class + is just assumed + - updated tests for this + + * examples/ + - added ArrayBasedStorage example to show + instance storage using ARRAY refs instead of + HASH refs. + - added tests for this + - InsideOutClass is totally revised using the + new instance protocol + - added more tests for this + +0.26 Mon. April 24, 2006 + * Class::MOP::Class + - added find_attribute_by_name method + - added tests and docs for this + - some small optimizations + + * Class::MOP::Attribute + - some small optimizations + +0.25 Thurs. April 20, 2006 + * Class::MOP::Class + - added create_anon_class for creating anonymous classes + - added tests for this + - added get_all_metaclasses, get_all_metaclass_names + and get_all_metaclass_instances method to allow + access to all the cached metaclass objects. + - attribute slot initialization is now the responsibility + of the attribute itself, and construct_instance now + delegates appropriately + + * Class::MOP::Attribute + - attribute slot initialization is now the responsibility + of the attribute itself, so we added a method for it + called initialize_instance_slot + + * examples/ + - adjusted all the examples to use the new attribute + initialize_instance_slot method + +0.24 Tues. April 11, 2006 + * Class::MOP::Class + - cleaned up how the before/after/around method + modifiers get named with Sub::Name + +0.23 Thurs. March 30, 2006 + * Class::MOP::Class + - fixed the way attribute defaults are handled + during instance construction (bug found by chansen) + + * Class::MOP::Attribute + - read-only accessors ('reader') will now die if + passed more than one argument (attempting to write + to them basically) + - added tests for this + - adjusted all /example files to comply + +0.22 Mon. March 20, 2006 + * Class::MOP::Class + - localized $@ in the *_package_variable functions + because otherwise, it does ugly things in Moose. + - added test case for this + +0.21 Wed. March 15, 2006 + * Class::MOP::Class + - fixed issue where metaclasses are reaped from + our cache in global destruction, and so are not + available in DESTORY calls + +0.20 Thurs. March 2, 2006 + - removed the dependency for Clone since + we no longer to deep-cloning by default. + + * Class::MOP::Method + - added &package_name, &name and + &fully_qualified_name methods, some of + which were formerly private subs in + Class::MOP::Class + + * Class::MOP::Method::Wrapped + - allows for a method to be wrapped with + before, after and around modifiers + - added tests and docs for this feature + + * Class::MOP::Class + - improved &get_package_symbol + - &version and &superclasses now use it + - methods are now blessed into Class::MOP::Method + whenever possible + - added methods to install CLOS-style method modifiers + - &add_before_method_modifier + - &add_after_method_modifier + - &add_around_method_modifier + - added tests and docs for these + - added &find_next_method_by_name which finds the + equivalent of SUPER::method_name + +0.12 Thurs. Feb 23, 2006 + - reduced the dependency on B, no need to always + have the latest + + * examples/ + - added docs to the C3 method dispatch order test + - fixed missing Algorithm::C3 dependency by making + the test skip if it is not installed + +0.11 Mon Feb. 20, 2006 + * examples/ + - added example of changing method dispatch order to C3 + + * Class::MOP::Class + - changed how clone_instance behaves, it now only does a + shallow clone (see docs for more details) + - added docs and tests + +0.10 Tues Feb. 14, 2006 + ** This release was mostly about writing more tests and + cleaning out old and dusty code, the MOP should now + be considered "ready to use". + + - adding more tests to get coverage up a little higher, + mostly testing errors and edge cases. + - test coverage is now at 99% + + * Class::MOP + - no longer optionally exports to UNIVERSAL::meta or + creates a custom metaclass generator, use the + metaclass pragma instead. + + * Class::MOP::Class + - fixed a number of minor issues which came up in the + error/edge-case tests + + * Class::MOP::Attribute + - fixed a number of minor issues which came up in the + error/edge-case tests + + * examples/ + - fixing the AttributesWithHistory example, it was broken. + +0.06 Thurs Feb. 9, 2006 + * metaclass + - adding new metaclass pragma to make setting up the + metaclass a little more straightforward + + * Class::MOP + - clean up bootstrapping to include more complete + attribute definitions for Class::MOP::Class and + Class::MOP::Attribute (accessors, readers, writers, + etc.) ... it is redundant, but is useful meta-info + to have around. + + * Class::MOP::Class + - fixing minor meta-circularity issue with &meta, it + is now more useful for subclasses + - added &get_attribute_map as an accessor for the + hash of attribute meta objects + - &compute_all_applicable_attributes now just returns + the attribute meta-object, rather than the HASH ref + since all the same info can be gotten from the + attribute meta-object itself + - updated docs & tests to reflect + - added &clone_instance method which does a deep clone + of the instance structure created by &construct_instance + - added docs & tests for this + - added Clone as a dependency + - added &new_object and &clone_object convience methods to + return blessed new or cloned instances + - they handle Class::MOP::Class singletons correctly too + - added docs & tests for this + - cleaned up the &constuct_class_instance so that it behaves + more like &construct_instance (and managed the singletons too) + - added the &check_metaclass_compatibility method to make sure + that metaclasses are upward and downward compatible. + - added tests and docs for this + + * examples/ + - adjusting code to use the &Class::MOP::Class::meta + fix detailed above + - adjusting code to use the metaclass pragma + +0.05 Sat Feb. 4, 2006 + * Class::MOP::Class + - added the &attribute_metaclass and &method_metaclass + attributes which contain a metaclass name to use for + attributes/methods respectively + + * Class::MOP + - bootstrap additional attributes for Class::MOP::Class + + * examples/ + - adjusted the example code and tests to use the new + &attribute_metaclass feature of Class::MOP::Class + - added new example: + - LazyClass + +0.04 Fri Feb. 3, 2006 + * Class::MOP::Class + - some documentation suggestions from #perl6 + + * Class::MOP::Attribute + - improved error messages + + * examples/ + - added new examples: + - AttributesWithHistory + - ClassEncapsultedAttributes + +0.03 Fri Feb. 3, 2006 + - converted to Module::Build instead of EU::MM + + * Class::MOP::Attribute + - refactored method generation code + - attributes are now associated with class directly + + * examples/ + - refactored the InsideOut example to take advantage + of the Class::MOP::Attribute refactoring + - changed example files to .pod files and hide thier + package names from PAUSE (I don't want to own these + namespaces really, they are just examples) + +0.02 Thurs Feb. 2, 2006 + - moving examples from t/lib/* to examples/* + - adding POD documentation to the examples + +0.01 Thurs Feb. 2, 2006 + - Initial release @@ -0,0 +1,379 @@ +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +Terms of the Perl programming language system itself + +a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or +b) the "Artistic License" + +--- The GNU General Public License, Version 1, February 1989 --- + +This software is Copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software, licensed under: + + The Artistic License 1.0 + +The Artistic License + +Preamble + +The intent of this document is to state the conditions under which a Package +may be copied, such that the Copyright Holder maintains some semblance of +artistic control over the development of the package, while giving the users of +the package the right to use and distribute the Package in a more-or-less +customary fashion, plus the right to make reasonable modifications. + +Definitions: + + - "Package" refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + - "Standard Version" refers to such a Package if it has not been modified, + or has been modified in accordance with the wishes of the Copyright + Holder. + - "Copyright Holder" is whoever is named in the copyright or copyrights for + the package. + - "You" is you, if you're thinking about copying or distributing this Package. + - "Reasonable copying fee" is whatever you can justify on the basis of media + cost, duplication charges, time of people involved, and so on. (You will + not be required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + - "Freely Available" means that no fee is charged for the item itself, though + there may be fees involved in handling the item. It also means that + recipients of the item may redistribute it under the same conditions they + received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications derived +from the Public Domain or from the Copyright Holder. A Package modified in such +a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided that +you insert a prominent notice in each changed file stating how and when you +changed that file, and provided that you do at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or an + equivalent medium, or placing the modifications on a major archive site + such as ftp.uu.net, or by allowing the Copyright Holder to include your + modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict with + standard executables, which must also be provided, and provide a separate + manual page for each non-standard executable that clearly documents how it + differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or executable +form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where to + get the Standard Version. + + b) accompany the distribution with the machine-readable source of the Package + with your modifications. + + c) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting the differences in manual pages (or + equivalent), together with instructions on where to get the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this Package. You +may not charge a fee for this Package itself. However, you may distribute this +Package in aggregate with other (possibly commercial) programs as part of a +larger (possibly commercial) software distribution provided that you do not +advertise this Package as a product of your own. + +6. The scripts and library files supplied as input to or produced as output +from the programs of this Package do not automatically fall under the copyright +of this Package, but belong to whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +The End + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..dae485e --- /dev/null +++ b/MANIFEST @@ -0,0 +1,1042 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.037. +Changes +Changes.Class-MOP +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README.md +TODO +author/docGenerator.pl +author/extract-inline-tests +author/find-dupe-test-numbers +benchmarks/caf_vs_moose.pl +benchmarks/cmop/all.yml +benchmarks/cmop/foo.pl +benchmarks/cmop/lib/Bench/Accessor.pm +benchmarks/cmop/lib/Bench/Construct.pm +benchmarks/cmop/lib/Bench/Run.pm +benchmarks/cmop/lib/MOP/Immutable/Point.pm +benchmarks/cmop/lib/MOP/Immutable/Point3D.pm +benchmarks/cmop/lib/MOP/Installed/Point.pm +benchmarks/cmop/lib/MOP/Installed/Point3D.pm +benchmarks/cmop/lib/MOP/Point.pm +benchmarks/cmop/lib/MOP/Point3D.pm +benchmarks/cmop/lib/Plain/Point.pm +benchmarks/cmop/lib/Plain/Point3D.pm +benchmarks/cmop/loading-benchmark.pl +benchmarks/cmop/profile.pl +benchmarks/cmop/run_yml.pl +benchmarks/immutable.pl +benchmarks/lotsa-classes.pl +benchmarks/method_modifiers.pl +benchmarks/moose_bench.pl +benchmarks/simple_class.pl +benchmarks/simple_compile.pl +benchmarks/simple_constructor.pl +benchmarks/type_constraints.pl +benchmarks/type_constraints2.pl +bin/moose-outdated +dist.ini +doc/moosex-compile +inc/CheckAuthorDeps.pm +inc/CheckDelta.pm +inc/CheckReleaseType.pm +inc/Clean.pm +inc/ExtractInlineTests.pm +inc/GenerateDocs.pm +inc/GitUpToDate.pm +inc/MMHelper.pm +inc/MakeMaker.pm +inc/MyInline.pm +inc/SimpleAuthority.pm +inc/SimpleProvides.pm +inc/TestRelease.pm +lib/Class/MOP.pm +lib/Class/MOP/Attribute.pm +lib/Class/MOP/Class.pm +lib/Class/MOP/Class/Immutable/Trait.pm +lib/Class/MOP/Deprecated.pm +lib/Class/MOP/Instance.pm +lib/Class/MOP/Method.pm +lib/Class/MOP/Method/Accessor.pm +lib/Class/MOP/Method/Constructor.pm +lib/Class/MOP/Method/Generated.pm +lib/Class/MOP/Method/Inlined.pm +lib/Class/MOP/Method/Meta.pm +lib/Class/MOP/Method/Wrapped.pm +lib/Class/MOP/MiniTrait.pm +lib/Class/MOP/Mixin.pm +lib/Class/MOP/Mixin/AttributeCore.pm +lib/Class/MOP/Mixin/HasAttributes.pm +lib/Class/MOP/Mixin/HasMethods.pm +lib/Class/MOP/Mixin/HasOverloads.pm +lib/Class/MOP/Module.pm +lib/Class/MOP/Object.pm +lib/Class/MOP/Overload.pm +lib/Class/MOP/Package.pm +lib/Moose.pm +lib/Moose/Conflicts.pm +lib/Moose/Cookbook.pod +lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod +lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod +lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod +lib/Moose/Cookbook/Basics/Company_Subtypes.pod +lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod +lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod +lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod +lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod +lib/Moose/Cookbook/Basics/Immutable.pod +lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod +lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod +lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod +lib/Moose/Cookbook/Extending/ExtensionOverview.pod +lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod +lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod +lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod +lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod +lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod +lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod +lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod +lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod +lib/Moose/Cookbook/Meta/WhyMeta.pod +lib/Moose/Cookbook/Roles/ApplicationToInstance.pod +lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod +lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod +lib/Moose/Cookbook/Snack/Keywords.pod +lib/Moose/Cookbook/Snack/Types.pod +lib/Moose/Cookbook/Style.pod +lib/Moose/Deprecated.pm +lib/Moose/Exception.pm +lib/Moose/Exception/AccessorMustReadWrite.pm +lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm +lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm +lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm +lib/Moose/Exception/ApplyTakesABlessedInstance.pm +lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm +lib/Moose/Exception/AttributeConflictInRoles.pm +lib/Moose/Exception/AttributeConflictInSummation.pm +lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm +lib/Moose/Exception/AttributeIsRequired.pm +lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm +lib/Moose/Exception/AttributeNamesDoNotMatch.pm +lib/Moose/Exception/AttributeValueIsNotAnObject.pm +lib/Moose/Exception/AttributeValueIsNotDefined.pm +lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm +lib/Moose/Exception/BadOptionFormat.pm +lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm +lib/Moose/Exception/BuilderDoesNotExist.pm +lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm +lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm +lib/Moose/Exception/BuilderMustBeAMethodName.pm +lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm +lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm +lib/Moose/Exception/CanExtendOnlyClasses.pm +lib/Moose/Exception/CanOnlyConsumeRole.pm +lib/Moose/Exception/CanOnlyWrapBlessedCode.pm +lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm +lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm +lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm +lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm +lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm +lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm +lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm +lib/Moose/Exception/CannotAugmentNoSuperMethod.pm +lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm +lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm +lib/Moose/Exception/CannotCalculateNativeType.pm +lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm +lib/Moose/Exception/CannotCallAnAbstractMethod.pm +lib/Moose/Exception/CannotCoerceAWeakRef.pm +lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm +lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm +lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm +lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm +lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm +lib/Moose/Exception/CannotDelegateWithoutIsa.pm +lib/Moose/Exception/CannotFindDelegateMetaclass.pm +lib/Moose/Exception/CannotFindType.pm +lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm +lib/Moose/Exception/CannotFixMetaclassCompatibility.pm +lib/Moose/Exception/CannotGenerateInlineConstraint.pm +lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm +lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm +lib/Moose/Exception/CannotLocatePackageInINC.pm +lib/Moose/Exception/CannotMakeMetaclassCompatible.pm +lib/Moose/Exception/CannotOverrideALocalMethod.pm +lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm +lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm +lib/Moose/Exception/CannotOverrideNoSuperMethod.pm +lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm +lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm +lib/Moose/Exception/CircularReferenceInAlso.pm +lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm +lib/Moose/Exception/ClassDoesTheExcludedRole.pm +lib/Moose/Exception/ClassNamesDoNotMatch.pm +lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm +lib/Moose/Exception/CodeBlockMustBeACodeRef.pm +lib/Moose/Exception/CoercingWithoutCoercions.pm +lib/Moose/Exception/CoercionAlreadyExists.pm +lib/Moose/Exception/CoercionNeedsTypeConstraint.pm +lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm +lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm +lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm +lib/Moose/Exception/CouldNotCreateMethod.pm +lib/Moose/Exception/CouldNotCreateWriter.pm +lib/Moose/Exception/CouldNotEvalConstructor.pm +lib/Moose/Exception/CouldNotEvalDestructor.pm +lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm +lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm +lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm +lib/Moose/Exception/CouldNotParseType.pm +lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm +lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm +lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm +lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm +lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm +lib/Moose/Exception/CreateTakesHashRefOfMethods.pm +lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm +lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm +lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm +lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm +lib/Moose/Exception/DoesRequiresRoleName.pm +lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm +lib/Moose/Exception/EnumValuesMustBeString.pm +lib/Moose/Exception/ExtendsMissingArgs.pm +lib/Moose/Exception/HandlesMustBeAHashRef.pm +lib/Moose/Exception/IllegalInheritedOptions.pm +lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm +lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm +lib/Moose/Exception/InitMetaRequiresClass.pm +lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm +lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm +lib/Moose/Exception/InstanceMustBeABlessedReference.pm +lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm +lib/Moose/Exception/InvalidArgumentToMethod.pm +lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm +lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm +lib/Moose/Exception/InvalidHandleValue.pm +lib/Moose/Exception/InvalidHasProvidedInARole.pm +lib/Moose/Exception/InvalidNameForType.pm +lib/Moose/Exception/InvalidOverloadOperator.pm +lib/Moose/Exception/InvalidRoleApplication.pm +lib/Moose/Exception/InvalidTypeConstraint.pm +lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm +lib/Moose/Exception/InvalidValueForIs.pm +lib/Moose/Exception/IsaDoesNotDoTheRole.pm +lib/Moose/Exception/IsaLacksDoesMethod.pm +lib/Moose/Exception/LazyAttributeNeedsADefault.pm +lib/Moose/Exception/Legacy.pm +lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm +lib/Moose/Exception/MatchActionMustBeACodeRef.pm +lib/Moose/Exception/MessageParameterMustBeCodeRef.pm +lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm +lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm +lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm +lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm +lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm +lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm +lib/Moose/Exception/MetaclassNotLoaded.pm +lib/Moose/Exception/MetaclassTypeIncompatible.pm +lib/Moose/Exception/MethodExpectedAMetaclassObject.pm +lib/Moose/Exception/MethodExpectsFewerArgs.pm +lib/Moose/Exception/MethodExpectsMoreArgs.pm +lib/Moose/Exception/MethodModifierNeedsMethodName.pm +lib/Moose/Exception/MethodNameConflictInRoles.pm +lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm +lib/Moose/Exception/MethodNameNotGiven.pm +lib/Moose/Exception/MustDefineAMethodName.pm +lib/Moose/Exception/MustDefineAnAttributeName.pm +lib/Moose/Exception/MustDefineAnOverloadOperator.pm +lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm +lib/Moose/Exception/MustPassAHashOfOptions.pm +lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm +lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm +lib/Moose/Exception/MustPassEvenNumberOfArguments.pm +lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm +lib/Moose/Exception/MustProvideANameForTheAttribute.pm +lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm +lib/Moose/Exception/MustSpecifyAtleastOneRole.pm +lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm +lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm +lib/Moose/Exception/MustSupplyADelegateToMethod.pm +lib/Moose/Exception/MustSupplyAMetaclass.pm +lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm +lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm +lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm +lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm +lib/Moose/Exception/MustSupplyPackageNameAndName.pm +lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm +lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm +lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm +lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm +lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm +lib/Moose/Exception/NoAttributeFoundInSuperClass.pm +lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm +lib/Moose/Exception/NoCasesMatched.pm +lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm +lib/Moose/Exception/NoDestructorClassSpecified.pm +lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm +lib/Moose/Exception/NoParentGivenToSubtype.pm +lib/Moose/Exception/OnlyInstancesCanBeCloned.pm +lib/Moose/Exception/OperatorIsRequired.pm +lib/Moose/Exception/OverloadConflictInSummation.pm +lib/Moose/Exception/OverloadRequiresAMetaClass.pm +lib/Moose/Exception/OverloadRequiresAMetaMethod.pm +lib/Moose/Exception/OverloadRequiresAMetaOverload.pm +lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm +lib/Moose/Exception/OverloadRequiresAnOperator.pm +lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm +lib/Moose/Exception/OverrideConflictInComposition.pm +lib/Moose/Exception/OverrideConflictInSummation.pm +lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm +lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm +lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm +lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm +lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm +lib/Moose/Exception/RequiredAttributeLacksInitialization.pm +lib/Moose/Exception/RequiredAttributeNeedsADefault.pm +lib/Moose/Exception/RequiredMethodsImportedByClass.pm +lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm +lib/Moose/Exception/Role/Attribute.pm +lib/Moose/Exception/Role/AttributeName.pm +lib/Moose/Exception/Role/Class.pm +lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm +lib/Moose/Exception/Role/Instance.pm +lib/Moose/Exception/Role/InstanceClass.pm +lib/Moose/Exception/Role/InvalidAttributeOptions.pm +lib/Moose/Exception/Role/Method.pm +lib/Moose/Exception/Role/ParamsHash.pm +lib/Moose/Exception/Role/Role.pm +lib/Moose/Exception/Role/RoleForCreate.pm +lib/Moose/Exception/Role/RoleForCreateMOPClass.pm +lib/Moose/Exception/Role/TypeConstraint.pm +lib/Moose/Exception/RoleDoesTheExcludedRole.pm +lib/Moose/Exception/RoleExclusionConflict.pm +lib/Moose/Exception/RoleNameRequired.pm +lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm +lib/Moose/Exception/RolesDoNotSupportAugment.pm +lib/Moose/Exception/RolesDoNotSupportExtends.pm +lib/Moose/Exception/RolesDoNotSupportInner.pm +lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm +lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm +lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm +lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm +lib/Moose/Exception/TriggerMustBeACodeRef.pm +lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm +lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm +lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm +lib/Moose/Exception/UnableToCanonicalizeHandles.pm +lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm +lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm +lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm +lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm +lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm +lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm +lib/Moose/Exception/ValidationFailedForTypeConstraint.pm +lib/Moose/Exception/WrapTakesACodeRefToBless.pm +lib/Moose/Exception/WrongTypeConstraintGiven.pm +lib/Moose/Exporter.pm +lib/Moose/Intro.pod +lib/Moose/Manual.pod +lib/Moose/Manual/Attributes.pod +lib/Moose/Manual/BestPractices.pod +lib/Moose/Manual/Classes.pod +lib/Moose/Manual/Concepts.pod +lib/Moose/Manual/Construction.pod +lib/Moose/Manual/Contributing.pod +lib/Moose/Manual/Delegation.pod +lib/Moose/Manual/Delta.pod +lib/Moose/Manual/Exceptions.pod +lib/Moose/Manual/Exceptions/Manifest.pod +lib/Moose/Manual/FAQ.pod +lib/Moose/Manual/MOP.pod +lib/Moose/Manual/MethodModifiers.pod +lib/Moose/Manual/MooseX.pod +lib/Moose/Manual/Resources.pod +lib/Moose/Manual/Roles.pod +lib/Moose/Manual/Support.pod +lib/Moose/Manual/Types.pod +lib/Moose/Manual/Unsweetened.pod +lib/Moose/Meta/Attribute.pm +lib/Moose/Meta/Attribute/Native.pm +lib/Moose/Meta/Attribute/Native/Trait.pm +lib/Moose/Meta/Attribute/Native/Trait/Array.pm +lib/Moose/Meta/Attribute/Native/Trait/Bool.pm +lib/Moose/Meta/Attribute/Native/Trait/Code.pm +lib/Moose/Meta/Attribute/Native/Trait/Counter.pm +lib/Moose/Meta/Attribute/Native/Trait/Hash.pm +lib/Moose/Meta/Attribute/Native/Trait/Number.pm +lib/Moose/Meta/Attribute/Native/Trait/String.pm +lib/Moose/Meta/Class.pm +lib/Moose/Meta/Class/Immutable/Trait.pm +lib/Moose/Meta/Instance.pm +lib/Moose/Meta/Method.pm +lib/Moose/Meta/Method/Accessor.pm +lib/Moose/Meta/Method/Accessor/Native.pm +lib/Moose/Meta/Method/Accessor/Native/Array.pm +lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm +lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm +lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm +lib/Moose/Meta/Method/Accessor/Native/Array/count.pm +lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm +lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm +lib/Moose/Meta/Method/Accessor/Native/Array/first.pm +lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm +lib/Moose/Meta/Method/Accessor/Native/Array/get.pm +lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm +lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm +lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm +lib/Moose/Meta/Method/Accessor/Native/Array/join.pm +lib/Moose/Meta/Method/Accessor/Native/Array/map.pm +lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm +lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm +lib/Moose/Meta/Method/Accessor/Native/Array/push.pm +lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm +lib/Moose/Meta/Method/Accessor/Native/Array/set.pm +lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm +lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm +lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm +lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm +lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm +lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm +lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm +lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm +lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm +lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm +lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm +lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm +lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm +lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm +lib/Moose/Meta/Method/Accessor/Native/Collection.pm +lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm +lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm +lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm +lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm +lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm +lib/Moose/Meta/Method/Accessor/Native/Hash.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm +lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm +lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm +lib/Moose/Meta/Method/Accessor/Native/Number/add.pm +lib/Moose/Meta/Method/Accessor/Native/Number/div.pm +lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm +lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm +lib/Moose/Meta/Method/Accessor/Native/Number/set.pm +lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm +lib/Moose/Meta/Method/Accessor/Native/Reader.pm +lib/Moose/Meta/Method/Accessor/Native/String/append.pm +lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm +lib/Moose/Meta/Method/Accessor/Native/String/chop.pm +lib/Moose/Meta/Method/Accessor/Native/String/clear.pm +lib/Moose/Meta/Method/Accessor/Native/String/inc.pm +lib/Moose/Meta/Method/Accessor/Native/String/length.pm +lib/Moose/Meta/Method/Accessor/Native/String/match.pm +lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm +lib/Moose/Meta/Method/Accessor/Native/String/replace.pm +lib/Moose/Meta/Method/Accessor/Native/String/substr.pm +lib/Moose/Meta/Method/Accessor/Native/Writer.pm +lib/Moose/Meta/Method/Augmented.pm +lib/Moose/Meta/Method/Constructor.pm +lib/Moose/Meta/Method/Delegation.pm +lib/Moose/Meta/Method/Destructor.pm +lib/Moose/Meta/Method/Meta.pm +lib/Moose/Meta/Method/Overridden.pm +lib/Moose/Meta/Mixin/AttributeCore.pm +lib/Moose/Meta/Object/Trait.pm +lib/Moose/Meta/Role.pm +lib/Moose/Meta/Role/Application.pm +lib/Moose/Meta/Role/Application/RoleSummation.pm +lib/Moose/Meta/Role/Application/ToClass.pm +lib/Moose/Meta/Role/Application/ToInstance.pm +lib/Moose/Meta/Role/Application/ToRole.pm +lib/Moose/Meta/Role/Attribute.pm +lib/Moose/Meta/Role/Composite.pm +lib/Moose/Meta/Role/Method.pm +lib/Moose/Meta/Role/Method/Conflicting.pm +lib/Moose/Meta/Role/Method/Required.pm +lib/Moose/Meta/TypeCoercion.pm +lib/Moose/Meta/TypeCoercion/Union.pm +lib/Moose/Meta/TypeConstraint.pm +lib/Moose/Meta/TypeConstraint/Class.pm +lib/Moose/Meta/TypeConstraint/DuckType.pm +lib/Moose/Meta/TypeConstraint/Enum.pm +lib/Moose/Meta/TypeConstraint/Parameterizable.pm +lib/Moose/Meta/TypeConstraint/Parameterized.pm +lib/Moose/Meta/TypeConstraint/Registry.pm +lib/Moose/Meta/TypeConstraint/Role.pm +lib/Moose/Meta/TypeConstraint/Union.pm +lib/Moose/Object.pm +lib/Moose/Role.pm +lib/Moose/Spec/Role.pod +lib/Moose/Unsweetened.pod +lib/Moose/Util.pm +lib/Moose/Util/MetaRole.pm +lib/Moose/Util/TypeConstraints.pm +lib/Moose/Util/TypeConstraints/Builtins.pm +lib/Test/Moose.pm +lib/metaclass.pm +lib/oose.pm +mop.c +mop.h +perltidyrc +ppport.h +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/000_load.t +t/attributes/accessor_context.t +t/attributes/accessor_inlining.t +t/attributes/accessor_override_method.t +t/attributes/accessor_overwrite_warning.t +t/attributes/attr_dereference_test.t +t/attributes/attribute_accessor_generation.t +t/attributes/attribute_custom_metaclass.t +t/attributes/attribute_delegation.t +t/attributes/attribute_does.t +t/attributes/attribute_inherited_slot_specs.t +t/attributes/attribute_lazy_initializer.t +t/attributes/attribute_names.t +t/attributes/attribute_reader_generation.t +t/attributes/attribute_required.t +t/attributes/attribute_traits.t +t/attributes/attribute_traits_n_meta.t +t/attributes/attribute_traits_parameterized.t +t/attributes/attribute_traits_registered.t +t/attributes/attribute_triggers.t +t/attributes/attribute_type_unions.t +t/attributes/attribute_without_any_methods.t +t/attributes/attribute_writer_generation.t +t/attributes/bad_coerce.t +t/attributes/chained_coercion.t +t/attributes/clone_weak.t +t/attributes/default_class_role_types.t +t/attributes/default_undef.t +t/attributes/delegation_and_modifiers.t +t/attributes/delegation_arg_aliasing.t +t/attributes/delegation_target_not_loaded.t +t/attributes/illegal_options_for_inheritance.t +t/attributes/inherit_lazy_build.t +t/attributes/lazy_no_default.t +t/attributes/method_generation_rules.t +t/attributes/misc_attribute_coerce_lazy.t +t/attributes/misc_attribute_tests.t +t/attributes/more_attr_delegation.t +t/attributes/no_init_arg.t +t/attributes/no_slot_access.t +t/attributes/non_alpha_attr_names.t +t/attributes/numeric_defaults.t +t/attributes/trigger_and_coerce.t +t/attributes/type_constraint.t +t/basics/always_strict_warnings.t +t/basics/basic_class_setup.t +t/basics/buildargs.t +t/basics/buildargs_warning.t +t/basics/create.t +t/basics/create_anon.t +t/basics/deprecations.t +t/basics/destruction.t +t/basics/error_handling.t +t/basics/global-destruction-helper.pl +t/basics/global_destruction.t +t/basics/import_unimport.t +t/basics/inner_and_augment.t +t/basics/load_into_main.t +t/basics/method_modifier_with_regexp.t +t/basics/methods.t +t/basics/moose_object_does.t +t/basics/moose_respects_type_constraints.t +t/basics/override_and_foreign_classes.t +t/basics/override_augment_inner_super.t +t/basics/rebless.t +t/basics/require_superclasses.t +t/basics/super_and_override.t +t/basics/super_warns_on_args.t +t/basics/universal_methods_wrappable.t +t/basics/wrapped_method_cxt_propagation.t +t/bugs/DEMOLISHALL.t +t/bugs/DEMOLISHALL_shortcutted.t +t/bugs/DEMOLISH_eats_exceptions.t +t/bugs/DEMOLISH_eats_mini.t +t/bugs/DEMOLISH_fails_without_metaclass.t +t/bugs/Moose_Object_error.t +t/bugs/anon_method_metaclass.t +t/bugs/application_metarole_compat.t +t/bugs/apply_role_to_one_instance_only.t +t/bugs/attribute_trait_parameters.t +t/bugs/augment_recursion_bug.t +t/bugs/coerce_without_coercion.t +t/bugs/constructor_object_overload.t +t/bugs/create_anon_recursion.t +t/bugs/create_anon_role_pass.t +t/bugs/delete_sub_stash.t +t/bugs/handles_foreign_class_bug.t +t/bugs/immutable_metaclass_does_role.t +t/bugs/immutable_n_default_x2.t +t/bugs/inheriting_from_roles.t +t/bugs/inline_reader_bug.t +t/bugs/instance_application_role_args.t +t/bugs/lazybuild_required_undef.t +t/bugs/mark_as_methods_overloading_breakage.t +t/bugs/moose_exporter_false_circular_reference_rt_63818.t +t/bugs/moose_octal_defaults.t +t/bugs/native_trait_handles_bad_value.t +t/bugs/overloading_edge_cases.t +t/bugs/reader_precedence_bug.t +t/bugs/role_caller.t +t/bugs/subclass_use_base_bug.t +t/bugs/subtype_conflict_bug.t +t/bugs/subtype_quote_bug.t +t/bugs/super_recursion.t +t/bugs/traits_with_exporter.t +t/bugs/type_constraint_messages.t +t/cmop/ArrayBasedStorage_test.t +t/cmop/AttributesWithHistory_test.t +t/cmop/BinaryTree_test.t +t/cmop/C3MethodDispatchOrder_test.t +t/cmop/ClassEncapsulatedAttributes_test.t +t/cmop/Class_C3_compatibility.t +t/cmop/InsideOutClass_test.t +t/cmop/InstanceCountingClass_test.t +t/cmop/LazyClass_test.t +t/cmop/Perl6Attribute_test.t +t/cmop/RT_27329_fix.t +t/cmop/RT_39001_fix.t +t/cmop/RT_41255.t +t/cmop/add_attribute_alternate.t +t/cmop/add_method_debugmode.t +t/cmop/add_method_modifier.t +t/cmop/advanced_methods.t +t/cmop/anon_class.t +t/cmop/anon_class_create_init.t +t/cmop/anon_class_keep_alive.t +t/cmop/anon_class_leak.t +t/cmop/anon_class_removal.t +t/cmop/anon_packages.t +t/cmop/attribute.t +t/cmop/attribute_duplication.t +t/cmop/attribute_errors_and_edge_cases.t +t/cmop/attribute_get_read_write.t +t/cmop/attribute_initializer.t +t/cmop/attribute_introspection.t +t/cmop/attribute_non_alpha_name.t +t/cmop/attributes.t +t/cmop/basic.t +t/cmop/before_after_dollar_under.t +t/cmop/class_errors_and_edge_cases.t +t/cmop/class_is_pristine.t +t/cmop/class_precedence_list.t +t/cmop/constant_codeinfo.t +t/cmop/create_class.t +t/cmop/custom_instance.t +t/cmop/deprecated.t +t/cmop/get_code_info.t +t/cmop/immutable_custom_trait.t +t/cmop/immutable_metaclass.t +t/cmop/immutable_w_constructors.t +t/cmop/immutable_w_custom_metaclass.t +t/cmop/inline_and_dollar_at.t +t/cmop/inline_structor.t +t/cmop/insertion_order.t +t/cmop/instance.t +t/cmop/instance_inline.t +t/cmop/instance_metaclass_incompat.t +t/cmop/instance_metaclass_incompat_dyn.t +t/cmop/lib/ArrayBasedStorage.pm +t/cmop/lib/AttributesWithHistory.pm +t/cmop/lib/BinaryTree.pm +t/cmop/lib/C3MethodDispatchOrder.pm +t/cmop/lib/ClassEncapsulatedAttributes.pm +t/cmop/lib/InsideOutClass.pm +t/cmop/lib/InstanceCountingClass.pm +t/cmop/lib/LazyClass.pm +t/cmop/lib/MyMetaClass.pm +t/cmop/lib/MyMetaClass/Attribute.pm +t/cmop/lib/MyMetaClass/Instance.pm +t/cmop/lib/MyMetaClass/Method.pm +t/cmop/lib/MyMetaClass/Random.pm +t/cmop/lib/Perl6Attribute.pm +t/cmop/lib/SyntaxError.pm +t/cmop/load.t +t/cmop/magic.t +t/cmop/make_mutable.t +t/cmop/meta_method.t +t/cmop/meta_package.t +t/cmop/meta_package_extension.t +t/cmop/metaclass.t +t/cmop/metaclass_incompatibility.t +t/cmop/metaclass_incompatibility_dyn.t +t/cmop/metaclass_inheritance.t +t/cmop/metaclass_loads_classes.t +t/cmop/metaclass_reinitialize.t +t/cmop/method.t +t/cmop/method_modifiers.t +t/cmop/methods.t +t/cmop/modify_parent_method.t +t/cmop/new_and_clone_metaclasses.t +t/cmop/null_stash.t +t/cmop/numeric_defaults.t +t/cmop/package_variables.t +t/cmop/random_eval_bug.t +t/cmop/rebless_instance.t +t/cmop/rebless_instance_away.t +t/cmop/rebless_overload.t +t/cmop/rebless_with_extra_params.t +t/cmop/scala_style_mixin_composition.t +t/cmop/self_introspection.t +t/cmop/subclasses.t +t/cmop/subname.t +t/cmop/universal_methods.t +t/compat/composite_metaroles.t +t/compat/extends_nonmoose_that_isa_moose_with_metarole.t +t/compat/foreign_inheritence.t +t/compat/inc_hash.t +t/compat/module_refresh_compat.t +t/compat/moose_respects_base.t +t/examples/Child_Parent_attr_inherit.t +t/examples/example1.t +t/examples/example2.t +t/examples/example_Moose_POOP.t +t/examples/example_Protomoose.t +t/examples/example_w_DCS.t +t/examples/example_w_TestDeep.t +t/examples/record_set_iterator.t +t/exceptions/attribute.t +t/exceptions/class-mop-attribute.t +t/exceptions/class-mop-class-immutable-trait.t +t/exceptions/class-mop-class.t +t/exceptions/class-mop-method-accessor.t +t/exceptions/class-mop-method-constructor.t +t/exceptions/class-mop-method-generated.t +t/exceptions/class-mop-method-meta.t +t/exceptions/class-mop-method-wrapped.t +t/exceptions/class-mop-method.t +t/exceptions/class-mop-mixin-hasattributes.t +t/exceptions/class-mop-mixin-hasmethods.t +t/exceptions/class-mop-module.t +t/exceptions/class-mop-object.t +t/exceptions/class-mop-package.t +t/exceptions/class.t +t/exceptions/cmop.t +t/exceptions/exception-lazyattributeneedsadefault.t +t/exceptions/frame-leak.t +t/exceptions/meta-role.t +t/exceptions/metaclass.t +t/exceptions/moose-exporter.t +t/exceptions/moose-meta-attribute-native-traits.t +t/exceptions/moose-meta-class-immutable-trait.t +t/exceptions/moose-meta-method-accessor-native-array.t +t/exceptions/moose-meta-method-accessor-native-collection.t +t/exceptions/moose-meta-method-accessor-native-grep.t +t/exceptions/moose-meta-method-accessor-native-hash-set.t +t/exceptions/moose-meta-method-accessor-native-hash.t +t/exceptions/moose-meta-method-accessor-native-string-match.t +t/exceptions/moose-meta-method-accessor-native-string-replace.t +t/exceptions/moose-meta-method-accessor-native-string-substr.t +t/exceptions/moose-meta-method-accessor-native.t +t/exceptions/moose-meta-method-accessor.t +t/exceptions/moose-meta-method-augmented.t +t/exceptions/moose-meta-method-constructor.t +t/exceptions/moose-meta-method-delegation.t +t/exceptions/moose-meta-method-destructor.t +t/exceptions/moose-meta-method-overridden.t +t/exceptions/moose-meta-role-application-rolesummation.t +t/exceptions/moose-meta-role-application-toclass.t +t/exceptions/moose-meta-role-application-torole.t +t/exceptions/moose-meta-role-application.t +t/exceptions/moose-meta-role-attribute.t +t/exceptions/moose-meta-role-composite.t +t/exceptions/moose-meta-typecoercion-union.t +t/exceptions/moose-meta-typecoercion.t +t/exceptions/moose-meta-typeconstraint-enum.t +t/exceptions/moose-meta-typeconstraint-parameterizable.t +t/exceptions/moose-meta-typeconstraint-parameterized.t +t/exceptions/moose-meta-typeconstraint-registry.t +t/exceptions/moose-meta-typeconstraint.t +t/exceptions/moose-role.t +t/exceptions/moose-util-metarole.t +t/exceptions/moose-util-typeconstraints.t +t/exceptions/moose.t +t/exceptions/object.t +t/exceptions/overload.t +t/exceptions/rt-92818.t +t/exceptions/rt-94795.t +t/exceptions/stringify.t +t/exceptions/traits.t +t/exceptions/typeconstraints.t +t/exceptions/util.t +t/immutable/apply_roles_to_immutable.t +t/immutable/buildargs.t +t/immutable/constructor_is_not_moose.t +t/immutable/constructor_is_wrapped.t +t/immutable/default_values.t +t/immutable/definition_context.t +t/immutable/immutable_constructor_error.t +t/immutable/immutable_destroy.t +t/immutable/immutable_meta_class.t +t/immutable/immutable_metaclass_with_traits.t +t/immutable/immutable_moose.t +t/immutable/immutable_roundtrip.t +t/immutable/immutable_trigger_from_constructor.t +t/immutable/inline_close_over.t +t/immutable/inline_fallbacks.t +t/immutable/inlined_constructors_n_types.t +t/immutable/multiple_demolish_inline.t +t/lib/Bar.pm +t/lib/Bar7/Meta/Trait.pm +t/lib/Bar7/Meta/Trait2.pm +t/lib/Foo.pm +t/lib/Moose/Meta/Attribute/Custom/Bar.pm +t/lib/Moose/Meta/Attribute/Custom/Foo.pm +t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm +t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm +t/lib/MyExporter.pm +t/lib/MyMetaclassRole.pm +t/lib/MyMooseA.pm +t/lib/MyMooseB.pm +t/lib/MyMooseObject.pm +t/lib/NoInlineAttribute.pm +t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm +t/lib/Overloading/ClassWithCombiningRole.pm +t/lib/Overloading/ClassWithOneRole.pm +t/lib/Overloading/CombiningClass.pm +t/lib/Overloading/CombiningRole.pm +t/lib/Overloading/RoleConsumesOverloads.pm +t/lib/Overloading/RoleWithOverloads.pm +t/lib/Overloading/RoleWithoutOverloads.pm +t/lib/OverloadingTests.pm +t/lib/Real/Package.pm +t/lib/Role/BreakOnLoad.pm +t/lib/Role/Child.pm +t/lib/Role/Interface.pm +t/lib/Role/Parent.pm +t/metaclasses/create_anon_with_required_attr.t +t/metaclasses/custom_attr_meta_as_role.t +t/metaclasses/custom_attr_meta_with_roles.t +t/metaclasses/easy_init_meta.t +t/metaclasses/export_with_prototype.t +t/metaclasses/exporter_also_with_trait.t +t/metaclasses/exporter_meta_lookup.t +t/metaclasses/exporter_sub_names.t +t/metaclasses/goto_moose_import.t +t/metaclasses/immutable_metaclass_compat_bug.t +t/metaclasses/meta_name.t +t/metaclasses/metaclass_compat.t +t/metaclasses/metaclass_compat_no_fixing_bug.t +t/metaclasses/metaclass_compat_role_conflicts.t +t/metaclasses/metaclass_parameterized_traits.t +t/metaclasses/metaclass_traits.t +t/metaclasses/metarole.t +t/metaclasses/metarole_combination.t +t/metaclasses/metarole_on_anon.t +t/metaclasses/metarole_w_metaclass_pm.t +t/metaclasses/metaroles_of_metaroles.t +t/metaclasses/moose_exporter.t +t/metaclasses/moose_exporter_trait_aliases.t +t/metaclasses/moose_for_meta.t +t/metaclasses/moose_nonmoose_metatrait_init_order.t +t/metaclasses/moose_nonmoose_moose_chain_init_meta.t +t/metaclasses/moose_w_metaclass.t +t/metaclasses/new_metaclass.t +t/metaclasses/new_object_BUILD.t +t/metaclasses/overloading.t +t/metaclasses/reinitialize.t +t/metaclasses/use_base_of_moose.t +t/moose_util/apply_roles.t +t/moose_util/create_alias.t +t/moose_util/ensure_all_roles.t +t/moose_util/method_mod_args.t +t/moose_util/moose_util.t +t/moose_util/moose_util_does_role.t +t/moose_util/moose_util_search_class_by_role.t +t/moose_util/resolve_alias.t +t/moose_util/with_traits.t +t/native_traits/array_coerce.t +t/native_traits/array_from_role.t +t/native_traits/array_subtypes.t +t/native_traits/array_trigger.t +t/native_traits/collection_with_roles.t +t/native_traits/custom_instance.t +t/native_traits/hash_coerce.t +t/native_traits/hash_subtypes.t +t/native_traits/hash_trigger.t +t/native_traits/remove_attribute.t +t/native_traits/shallow_clone.t +t/native_traits/trait_array.t +t/native_traits/trait_bool.t +t/native_traits/trait_code.t +t/native_traits/trait_counter.t +t/native_traits/trait_hash.t +t/native_traits/trait_number.t +t/native_traits/trait_string.t +t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t +t/recipes/basics_binarytree_attributefeatures.t +t/recipes/basics_company_subtypes.t +t/recipes/basics_datetime_extendingnonmooseparent.t +t/recipes/basics_document_augmentandinner.t +t/recipes/basics_genome_overloadingsubtypesandcoercion.t +t/recipes/basics_http_subtypesandcoercion.t +t/recipes/basics_point_attributesandsubclassing.t +t/recipes/extending_debugging_baseclassrole.t +t/recipes/extending_mooseish_moosesugar.t +t/recipes/legacy_debugging_baseclassreplacement.t +t/recipes/legacy_labeled_attributemetaclass.t +t/recipes/meta_globref_instancemetaclass.t +t/recipes/meta_labeled_attributetrait.t +t/recipes/meta_privateorpublic_methodmetaclass.t +t/recipes/meta_table_metaclasstrait.t +t/recipes/roles_applicationtoinstance.t +t/recipes/roles_comparable_codereuse.t +t/recipes/roles_restartable_advancedcomposition.t +t/roles/anonymous_roles.t +t/roles/application_toclass.t +t/roles/apply_role.t +t/roles/build.t +t/roles/conflict_many_methods.t +t/roles/create_role.t +t/roles/create_role_subclass.t +t/roles/empty_method_modifiers_meta_bug.t +t/roles/extending_role_attrs.t +t/roles/free_anonymous_roles.t +t/roles/imported_required_method.t +t/roles/meta_role.t +t/roles/method_aliasing_in_composition.t +t/roles/method_exclusion_in_composition.t +t/roles/method_modifiers.t +t/roles/methods.t +t/roles/more_alias_and_exclude.t +t/roles/more_role_edge_cases.t +t/roles/new_meta_role.t +t/roles/overloading_combine_to_class.t +t/roles/overloading_combine_to_instance.t +t/roles/overloading_combine_to_role.t +t/roles/overloading_composition_errors.t +t/roles/overloading_remove_attributes_bug.t +t/roles/overloading_to_class.t +t/roles/overloading_to_instance.t +t/roles/overloading_to_role.t +t/roles/overriding.t +t/roles/reinitialize_anon_role.t +t/roles/role.t +t/roles/role_attr_application.t +t/roles/role_attribute_conflict.t +t/roles/role_attrs.t +t/roles/role_compose_requires.t +t/roles/role_composite.t +t/roles/role_composite_exclusion.t +t/roles/role_composition_attributes.t +t/roles/role_composition_conflict_detection.t +t/roles/role_composition_errors.t +t/roles/role_composition_method_mods.t +t/roles/role_composition_methods.t +t/roles/role_composition_override.t +t/roles/role_composition_req_methods.t +t/roles/role_conflict_detection.t +t/roles/role_conflict_edge_cases.t +t/roles/role_consumers.t +t/roles/role_exclusion.t +t/roles/role_exclusion_and_alias_bug.t +t/roles/role_for_combination.t +t/roles/roles_and_method_cloning.t +t/roles/roles_and_req_method_edge_cases.t +t/roles/roles_applied_in_create.t +t/roles/run_time_role_composition.t +t/roles/runtime_roles_and_attrs.t +t/roles/runtime_roles_and_nonmoose.t +t/roles/runtime_roles_w_params.t +t/roles/use_base_does.t +t/test_moose/test_moose.t +t/test_moose/test_moose_does_ok.t +t/test_moose/test_moose_has_attribute_ok.t +t/test_moose/test_moose_meta_ok.t +t/test_moose/with_immutable.t +t/todo_tests/exception_reflects_failed_constraint.t +t/todo_tests/immutable_n_around.t +t/todo_tests/moose_and_threads.t +t/todo_tests/replacing_super_methods.t +t/todo_tests/required_role_accessors.t +t/todo_tests/role_attr_methods_original_package.t +t/todo_tests/role_insertion_order.t +t/todo_tests/various_role_features.t +t/todo_tests/wrong-inner.t +t/type_constraints/advanced_type_creation.t +t/type_constraints/class_subtypes.t +t/type_constraints/class_type_constraint.t +t/type_constraints/coerced_parameterized_types.t +t/type_constraints/container_type_coercion.t +t/type_constraints/container_type_constraint.t +t/type_constraints/custom_parameterized_types.t +t/type_constraints/custom_type_errors.t +t/type_constraints/define_type_twice_throws.t +t/type_constraints/duck_type_handles.t +t/type_constraints/duck_types.t +t/type_constraints/enum.t +t/type_constraints/inlining.t +t/type_constraints/match_type_operator.t +t/type_constraints/maybe_type_constraint.t +t/type_constraints/misc_type_tests.t +t/type_constraints/name_conflicts.t +t/type_constraints/normalize_type_name.t +t/type_constraints/parameterize_from.t +t/type_constraints/role_type_constraint.t +t/type_constraints/subtype_auto_vivify_parent.t +t/type_constraints/subtyping_parameterized_types.t +t/type_constraints/subtyping_union_types.t +t/type_constraints/throw_error.t +t/type_constraints/type_coersion_on_lazy_attributes.t +t/type_constraints/type_names.t +t/type_constraints/type_notation_parser.t +t/type_constraints/types_and_undef.t +t/type_constraints/union_is_a_type_of.t +t/type_constraints/union_types.t +t/type_constraints/union_types_and_coercions.t +t/type_constraints/util_find_type_constraint.t +t/type_constraints/util_more_type_coercion.t +t/type_constraints/util_std_type_constraints.t +t/type_constraints/util_type_coercion.t +t/type_constraints/util_type_constraints.t +t/type_constraints/util_type_constraints_export.t +t/type_constraints/util_type_reloading.t +t/type_constraints/with-specio.t +t/zzz-check-breaks.t +xs/Attribute.xs +xs/AttributeCore.xs +xs/Class.xs +xs/Generated.xs +xs/HasAttributes.xs +xs/HasMethods.xs +xs/Inlined.xs +xs/Instance.xs +xs/MOP.xs +xs/Method.xs +xs/Moose.xs +xs/Package.xs +xs/ToInstance.xs +xs/typemap +xt/author/authority.t +xt/author/debugger-duck_type.t +xt/author/eol.t +xt/author/memory_leaks.t +xt/author/no-tabs.t +xt/author/pod-coverage.t +xt/author/pod-spell.t +xt/author/test-my-dependents.t +xt/release/00-compile.t +xt/release/cpan-changes.t +xt/release/distmeta.t +xt/release/kwalitee.t +xt/release/mojibake.t +xt/release/pod-syntax.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..e3cb289 --- /dev/null +++ b/META.json @@ -0,0 +1,2575 @@ +{ + "abstract" : "A postmodern object system for Perl 5", + "author" : [ + "Stevan Little <stevan.little@iinteractive.com>", + "Dave Rolsky <autarch@urth.org>", + "Jesse Luehrs <doy@tozt.net>", + "Shawn M Moore <code@sartak.org>", + "יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>", + "Karen Etheridge <ether@cpan.org>", + "Florian Ragwitz <rafl@debian.org>", + "Hans Dieter Pearcey <hdp@weftsoar.net>", + "Chris Prather <chris@prather.org>", + "Matt S Trout <mst@shadowcat.co.uk>" + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 5.037, CPAN::Meta::Converter version 2.150001", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Moose", + "no_index" : { + "directory" : [ + "author", + "benchmarks", + "doc", + "inc" + ], + "namespace" : [ + "Class::MOP::Mixin", + "Moose::Meta::Method::Accessor::Native", + "Moose::Meta::Mixin" + ], + "package" : [ + "Class::MOP::Class::Immutable::Trait", + "Class::MOP::Deprecated", + "Class::MOP::MiniTrait", + "Class::MOP::Mixin", + "Moose::Deprecated", + "Moose::Meta::Attribute::Native::Trait", + "Moose::Meta::Class::Immutable::Trait", + "Moose::Meta::Method::Accessor::Native", + "Moose::Meta::Object::Trait", + "Moose::Util::TypeConstraints::Builtins" + ] + }, + "prereqs" : { + "configure" : { + "requires" : { + "Dist::CheckConflicts" : "0.02", + "ExtUtils::CBuilder" : "0.27", + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0" + } + }, + "develop" : { + "requires" : { + "Algorithm::C3" : "0", + "Class::Load" : "0.07", + "DBM::Deep" : "1.003", + "Data::Visitor" : "0", + "DateTime" : "0", + "DateTime::Calendar::Mayan" : "0", + "DateTime::Format::MySQL" : "0", + "Declare::Constraints::Simple" : "0", + "ExtUtils::MakeMaker::Dist::Zilla::Develop" : "0", + "File::Find::Rule" : "0", + "File::Spec" : "0", + "HTTP::Headers" : "0", + "IO::File" : "0", + "IO::Handle" : "0", + "IO::String" : "0", + "IPC::Open3" : "0", + "Locale::US" : "0", + "Module::CPANTS::Analyse" : "0.92", + "Module::Refresh" : "0", + "MooseX::MarkAsMethods" : "0", + "MooseX::NonMoose" : "0", + "PadWalker" : "0", + "Params::Coerce" : "0", + "Regexp::Common" : "0", + "SUPER" : "1.10", + "Specio" : "0.10", + "Test::CPAN::Changes" : "0.19", + "Test::CPAN::Meta" : "0", + "Test::Deep" : "0", + "Test::EOL" : "0", + "Test::Inline" : "0", + "Test::Kwalitee" : "1.21", + "Test::LeakTrace" : "0", + "Test::Memory::Cycle" : "0", + "Test::More" : "0.94", + "Test::NoTabs" : "0", + "Test::Output" : "0", + "Test::Pod" : "1.41", + "Test::Pod::Coverage" : "1.04", + "Test::Spelling" : "0", + "URI" : "0", + "blib" : "0" + }, + "suggests" : { + "CPAN::Meta::Requirements" : "0", + "Carp" : "1.22", + "Class::Load" : "0.09", + "Class::Load::XS" : "0.01", + "Data::OptList" : "0.107", + "Devel::GlobalDestruction" : "0", + "Devel::OverloadInfo" : "0.002", + "Devel::StackTrace" : "1.33", + "Dist::Zilla" : "5", + "Dist::Zilla::Plugin::BumpVersionAfterRelease" : "0", + "Dist::Zilla::Plugin::CheckChangesHasContent" : "0", + "Dist::Zilla::Plugin::CheckVersionIncrement" : "0", + "Dist::Zilla::Plugin::ConfirmRelease" : "0", + "Dist::Zilla::Plugin::Conflicts" : "0.16", + "Dist::Zilla::Plugin::CopyFilesFromRelease" : "0", + "Dist::Zilla::Plugin::EnsurePrereqsInstalled" : "0.003", + "Dist::Zilla::Plugin::ExecDir" : "0", + "Dist::Zilla::Plugin::FileFinder::ByName" : "0", + "Dist::Zilla::Plugin::FileFinder::Filter" : "0", + "Dist::Zilla::Plugin::Git::Check" : "0", + "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0", + "Dist::Zilla::Plugin::Git::Commit" : "0", + "Dist::Zilla::Plugin::Git::Contributors" : "0", + "Dist::Zilla::Plugin::Git::Describe" : "0.004", + "Dist::Zilla::Plugin::Git::GatherDir" : "0", + "Dist::Zilla::Plugin::Git::Push" : "0", + "Dist::Zilla::Plugin::Git::Remote::Check" : "0", + "Dist::Zilla::Plugin::Git::Tag" : "0", + "Dist::Zilla::Plugin::License" : "0", + "Dist::Zilla::Plugin::MakeMaker::Awesome" : "0", + "Dist::Zilla::Plugin::Manifest" : "0", + "Dist::Zilla::Plugin::MetaConfig" : "0", + "Dist::Zilla::Plugin::MetaJSON" : "0", + "Dist::Zilla::Plugin::MetaNoIndex" : "0", + "Dist::Zilla::Plugin::MetaProvides::Package" : "1.15000002", + "Dist::Zilla::Plugin::MetaResources" : "0", + "Dist::Zilla::Plugin::MetaTests" : "0", + "Dist::Zilla::Plugin::MetaYAML" : "0", + "Dist::Zilla::Plugin::MojibakeTests" : "0", + "Dist::Zilla::Plugin::NextRelease" : "5.033", + "Dist::Zilla::Plugin::PodSyntaxTests" : "0", + "Dist::Zilla::Plugin::Prereqs" : "0", + "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0", + "Dist::Zilla::Plugin::PromptIfStale" : "0", + "Dist::Zilla::Plugin::RewriteVersion" : "0", + "Dist::Zilla::Plugin::Run::AfterRelease" : "0", + "Dist::Zilla::Plugin::RunExtraTests" : "0", + "Dist::Zilla::Plugin::ShareDir" : "0", + "Dist::Zilla::Plugin::SurgicalPodWeaver" : "0.0023", + "Dist::Zilla::Plugin::Test::CPAN::Changes" : "0", + "Dist::Zilla::Plugin::Test::CheckBreaks" : "0", + "Dist::Zilla::Plugin::Test::Compile" : "2.037", + "Dist::Zilla::Plugin::Test::EOL" : "0.14", + "Dist::Zilla::Plugin::Test::Kwalitee" : "0", + "Dist::Zilla::Plugin::Test::NoTabs" : "0", + "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0", + "Dist::Zilla::Plugin::TestRelease" : "0", + "Dist::Zilla::Plugin::UploadToCPAN" : "0", + "Dist::Zilla::Util::AuthorDeps" : "5.021", + "Eval::Closure" : "0.04", + "ExtUtils::CBuilder" : "0.27", + "File::Find::Rule" : "0", + "File::Spec" : "0", + "File::pushd" : "0", + "IPC::System::Simple" : "0", + "List::MoreUtils" : "0.28", + "List::Util" : "1.35", + "MRO::Compat" : "0.05", + "Module::Runtime" : "0.014", + "Module::Runtime::Conflicts" : "0.002", + "Package::DeprecationManager" : "0.11", + "Package::Stash" : "0.32", + "Package::Stash::XS" : "0.24", + "Params::Util" : "1.00", + "Path::Tiny" : "0", + "Scalar::Util" : "1.19", + "Sub::Exporter" : "0.980", + "Sub::Identify" : "0", + "Sub::Name" : "0.05", + "Task::Weaken" : "0", + "Test::Deep" : "0", + "Test::Inline" : "0", + "Test::Inline::Extract" : "0", + "Try::Tiny" : "0.17", + "parent" : "0.223", + "perl" : "v5.8.3", + "strict" : "1.03", + "warnings" : "1.03" + } + }, + "runtime" : { + "requires" : { + "Carp" : "1.22", + "Class::Load" : "0.09", + "Class::Load::XS" : "0.01", + "Data::OptList" : "0.107", + "Devel::GlobalDestruction" : "0", + "Devel::OverloadInfo" : "0.002", + "Devel::StackTrace" : "1.33", + "Dist::CheckConflicts" : "0.02", + "Eval::Closure" : "0.04", + "List::MoreUtils" : "0.28", + "List::Util" : "1.35", + "MRO::Compat" : "0.05", + "Module::Runtime" : "0.014", + "Module::Runtime::Conflicts" : "0.002", + "Package::DeprecationManager" : "0.11", + "Package::Stash" : "0.32", + "Package::Stash::XS" : "0.24", + "Params::Util" : "1.00", + "Scalar::Util" : "1.19", + "Sub::Exporter" : "0.980", + "Sub::Identify" : "0", + "Sub::Name" : "0.05", + "Task::Weaken" : "0", + "Try::Tiny" : "0.17", + "parent" : "0.223", + "perl" : "v5.8.3", + "strict" : "1.03", + "warnings" : "1.03" + }, + "suggests" : { + "Devel::PartialDump" : "0.14" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900" + }, + "requires" : { + "CPAN::Meta::Check" : "0.007", + "CPAN::Meta::Requirements" : "0", + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "Test::CleanNamespaces" : "0.13", + "Test::Fatal" : "0.001", + "Test::More" : "0.88", + "Test::Requires" : "0.05", + "Test::Warnings" : "0.016" + } + } + }, + "provides" : { + "Class::MOP" : { + "file" : "lib/Class/MOP.pm", + "version" : "2.1405" + }, + "Class::MOP::Attribute" : { + "file" : "lib/Class/MOP/Attribute.pm", + "version" : "2.1405" + }, + "Class::MOP::Class" : { + "file" : "lib/Class/MOP/Class.pm", + "version" : "2.1405" + }, + "Class::MOP::Instance" : { + "file" : "lib/Class/MOP/Instance.pm", + "version" : "2.1405" + }, + "Class::MOP::Method" : { + "file" : "lib/Class/MOP/Method.pm", + "version" : "2.1405" + }, + "Class::MOP::Method::Accessor" : { + "file" : "lib/Class/MOP/Method/Accessor.pm", + "version" : "2.1405" + }, + "Class::MOP::Method::Constructor" : { + "file" : "lib/Class/MOP/Method/Constructor.pm", + "version" : "2.1405" + }, + "Class::MOP::Method::Generated" : { + "file" : "lib/Class/MOP/Method/Generated.pm", + "version" : "2.1405" + }, + "Class::MOP::Method::Inlined" : { + "file" : "lib/Class/MOP/Method/Inlined.pm", + "version" : "2.1405" + }, + "Class::MOP::Method::Meta" : { + "file" : "lib/Class/MOP/Method/Meta.pm", + "version" : "2.1405" + }, + "Class::MOP::Method::Wrapped" : { + "file" : "lib/Class/MOP/Method/Wrapped.pm", + "version" : "2.1405" + }, + "Class::MOP::Module" : { + "file" : "lib/Class/MOP/Module.pm", + "version" : "2.1405" + }, + "Class::MOP::Object" : { + "file" : "lib/Class/MOP/Object.pm", + "version" : "2.1405" + }, + "Class::MOP::Overload" : { + "file" : "lib/Class/MOP/Overload.pm", + "version" : "2.1405" + }, + "Class::MOP::Package" : { + "file" : "lib/Class/MOP/Package.pm", + "version" : "2.1405" + }, + "Moose" : { + "file" : "lib/Moose.pm", + "version" : "2.1405" + }, + "Moose::Cookbook" : { + "file" : "lib/Moose/Cookbook.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing" : { + "file" : "lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::BinaryTree_AttributeFeatures" : { + "file" : "lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild" : { + "file" : "lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::Company_Subtypes" : { + "file" : "lib/Moose/Cookbook/Basics/Company_Subtypes.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent" : { + "file" : "lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::Document_AugmentAndInner" : { + "file" : "lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion" : { + "file" : "lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion" : { + "file" : "lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::Immutable" : { + "file" : "lib/Moose/Cookbook/Basics/Immutable.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD" : { + "file" : "lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Basics::Point_AttributesAndSubclassing" : { + "file" : "lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Extending::Debugging_BaseClassRole" : { + "file" : "lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Extending::ExtensionOverview" : { + "file" : "lib/Moose/Cookbook/Extending/ExtensionOverview.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Extending::Mooseish_MooseSugar" : { + "file" : "lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Legacy::Debugging_BaseClassReplacement" : { + "file" : "lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Legacy::Labeled_AttributeMetaclass" : { + "file" : "lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Legacy::Table_ClassMetaclass" : { + "file" : "lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Meta::GlobRef_InstanceMetaclass" : { + "file" : "lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Meta::Labeled_AttributeTrait" : { + "file" : "lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass" : { + "file" : "lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Meta::Table_MetaclassTrait" : { + "file" : "lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Meta::WhyMeta" : { + "file" : "lib/Moose/Cookbook/Meta/WhyMeta.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Roles::ApplicationToInstance" : { + "file" : "lib/Moose/Cookbook/Roles/ApplicationToInstance.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Roles::Comparable_CodeReuse" : { + "file" : "lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Roles::Restartable_AdvancedComposition" : { + "file" : "lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Snack::Keywords" : { + "file" : "lib/Moose/Cookbook/Snack/Keywords.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Snack::Types" : { + "file" : "lib/Moose/Cookbook/Snack/Types.pod", + "version" : "2.1405" + }, + "Moose::Cookbook::Style" : { + "file" : "lib/Moose/Cookbook/Style.pod", + "version" : "2.1405" + }, + "Moose::Exception" : { + "file" : "lib/Moose/Exception.pm", + "version" : "2.1405" + }, + "Moose::Exception::AccessorMustReadWrite" : { + "file" : "lib/Moose/Exception/AccessorMustReadWrite.pm", + "version" : "2.1405" + }, + "Moose::Exception::AddParameterizableTypeTakesParameterizableType" : { + "file" : "lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm", + "version" : "2.1405" + }, + "Moose::Exception::AddRoleTakesAMooseMetaRoleInstance" : { + "file" : "lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::AddRoleToARoleTakesAMooseMetaRole" : { + "file" : "lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::ApplyTakesABlessedInstance" : { + "file" : "lib/Moose/Exception/ApplyTakesABlessedInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttachToClassNeedsAClassMOPClassInstanceOrASubclass" : { + "file" : "lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeConflictInRoles" : { + "file" : "lib/Moose/Exception/AttributeConflictInRoles.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeConflictInSummation" : { + "file" : "lib/Moose/Exception/AttributeConflictInSummation.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeExtensionIsNotSupportedInRoles" : { + "file" : "lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeIsRequired" : { + "file" : "lib/Moose/Exception/AttributeIsRequired.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass" : { + "file" : "lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeNamesDoNotMatch" : { + "file" : "lib/Moose/Exception/AttributeNamesDoNotMatch.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeValueIsNotAnObject" : { + "file" : "lib/Moose/Exception/AttributeValueIsNotAnObject.pm", + "version" : "2.1405" + }, + "Moose::Exception::AttributeValueIsNotDefined" : { + "file" : "lib/Moose/Exception/AttributeValueIsNotDefined.pm", + "version" : "2.1405" + }, + "Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef" : { + "file" : "lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::BadOptionFormat" : { + "file" : "lib/Moose/Exception/BadOptionFormat.pm", + "version" : "2.1405" + }, + "Moose::Exception::BothBuilderAndDefaultAreNotAllowed" : { + "file" : "lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm", + "version" : "2.1405" + }, + "Moose::Exception::BuilderDoesNotExist" : { + "file" : "lib/Moose/Exception/BuilderDoesNotExist.pm", + "version" : "2.1405" + }, + "Moose::Exception::BuilderMethodNotSupportedForAttribute" : { + "file" : "lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm", + "version" : "2.1405" + }, + "Moose::Exception::BuilderMethodNotSupportedForInlineAttribute" : { + "file" : "lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm", + "version" : "2.1405" + }, + "Moose::Exception::BuilderMustBeAMethodName" : { + "file" : "lib/Moose/Exception/BuilderMustBeAMethodName.pm", + "version" : "2.1405" + }, + "Moose::Exception::CallingMethodOnAnImmutableInstance" : { + "file" : "lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::CallingReadOnlyMethodOnAnImmutableInstance" : { + "file" : "lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::CanExtendOnlyClasses" : { + "file" : "lib/Moose/Exception/CanExtendOnlyClasses.pm", + "version" : "2.1405" + }, + "Moose::Exception::CanOnlyConsumeRole" : { + "file" : "lib/Moose/Exception/CanOnlyConsumeRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::CanOnlyWrapBlessedCode" : { + "file" : "lib/Moose/Exception/CanOnlyWrapBlessedCode.pm", + "version" : "2.1405" + }, + "Moose::Exception::CanReblessOnlyIntoASubclass" : { + "file" : "lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::CanReblessOnlyIntoASuperclass" : { + "file" : "lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAddAdditionalTypeCoercionsToUnion" : { + "file" : "lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAddAsAnAttributeToARole" : { + "file" : "lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotApplyBaseClassRolesToRole" : { + "file" : "lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAssignValueToReadOnlyAccessor" : { + "file" : "lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAugmentIfLocalMethodPresent" : { + "file" : "lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAugmentNoSuperMethod" : { + "file" : "lib/Moose/Exception/CannotAugmentNoSuperMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAutoDerefWithoutIsa" : { + "file" : "lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotAutoDereferenceTypeConstraint" : { + "file" : "lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCalculateNativeType" : { + "file" : "lib/Moose/Exception/CannotCalculateNativeType.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCallAnAbstractBaseMethod" : { + "file" : "lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCallAnAbstractMethod" : { + "file" : "lib/Moose/Exception/CannotCallAnAbstractMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCoerceAWeakRef" : { + "file" : "lib/Moose/Exception/CannotCoerceAWeakRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion" : { + "file" : "lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCreateHigherOrderTypeWithoutATypeParameter" : { + "file" : "lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresent" : { + "file" : "lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresentInClass" : { + "file" : "lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotDelegateLocalMethodIsPresent" : { + "file" : "lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotDelegateWithoutIsa" : { + "file" : "lib/Moose/Exception/CannotDelegateWithoutIsa.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotFindDelegateMetaclass" : { + "file" : "lib/Moose/Exception/CannotFindDelegateMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotFindType" : { + "file" : "lib/Moose/Exception/CannotFindType.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotFindTypeGivenToMatchOnType" : { + "file" : "lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotFixMetaclassCompatibility" : { + "file" : "lib/Moose/Exception/CannotFixMetaclassCompatibility.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotGenerateInlineConstraint" : { + "file" : "lib/Moose/Exception/CannotGenerateInlineConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotInitializeMooseMetaRoleComposite" : { + "file" : "lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotInlineTypeConstraintCheck" : { + "file" : "lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotLocatePackageInINC" : { + "file" : "lib/Moose/Exception/CannotLocatePackageInINC.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotMakeMetaclassCompatible" : { + "file" : "lib/Moose/Exception/CannotMakeMetaclassCompatible.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotOverrideALocalMethod" : { + "file" : "lib/Moose/Exception/CannotOverrideALocalMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotOverrideBodyOfMetaMethods" : { + "file" : "lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotOverrideLocalMethodIsPresent" : { + "file" : "lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotOverrideNoSuperMethod" : { + "file" : "lib/Moose/Exception/CannotOverrideNoSuperMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotRegisterUnnamedTypeConstraint" : { + "file" : "lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously" : { + "file" : "lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm", + "version" : "2.1405" + }, + "Moose::Exception::CircularReferenceInAlso" : { + "file" : "lib/Moose/Exception/CircularReferenceInAlso.pm", + "version" : "2.1405" + }, + "Moose::Exception::ClassDoesNotHaveInitMeta" : { + "file" : "lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm", + "version" : "2.1405" + }, + "Moose::Exception::ClassDoesTheExcludedRole" : { + "file" : "lib/Moose/Exception/ClassDoesTheExcludedRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::ClassNamesDoNotMatch" : { + "file" : "lib/Moose/Exception/ClassNamesDoNotMatch.pm", + "version" : "2.1405" + }, + "Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass" : { + "file" : "lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::CodeBlockMustBeACodeRef" : { + "file" : "lib/Moose/Exception/CodeBlockMustBeACodeRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::CoercingWithoutCoercions" : { + "file" : "lib/Moose/Exception/CoercingWithoutCoercions.pm", + "version" : "2.1405" + }, + "Moose::Exception::CoercionAlreadyExists" : { + "file" : "lib/Moose/Exception/CoercionAlreadyExists.pm", + "version" : "2.1405" + }, + "Moose::Exception::CoercionNeedsTypeConstraint" : { + "file" : "lib/Moose/Exception/CoercionNeedsTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::ConflictDetectedInCheckRoleExclusions" : { + "file" : "lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm", + "version" : "2.1405" + }, + "Moose::Exception::ConflictDetectedInCheckRoleExclusionsInToClass" : { + "file" : "lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::ConstructClassInstanceTakesPackageName" : { + "file" : "lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotCreateMethod" : { + "file" : "lib/Moose/Exception/CouldNotCreateMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotCreateWriter" : { + "file" : "lib/Moose/Exception/CouldNotCreateWriter.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotEvalConstructor" : { + "file" : "lib/Moose/Exception/CouldNotEvalConstructor.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotEvalDestructor" : { + "file" : "lib/Moose/Exception/CouldNotEvalDestructor.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotFindTypeConstraintToCoerceFrom" : { + "file" : "lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod" : { + "file" : "lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotLocateTypeConstraintForUnion" : { + "file" : "lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm", + "version" : "2.1405" + }, + "Moose::Exception::CouldNotParseType" : { + "file" : "lib/Moose/Exception/CouldNotParseType.pm", + "version" : "2.1405" + }, + "Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes" : { + "file" : "lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm", + "version" : "2.1405" + }, + "Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses" : { + "file" : "lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm", + "version" : "2.1405" + }, + "Moose::Exception::CreateMOPClassTakesHashRefOfMethods" : { + "file" : "lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm", + "version" : "2.1405" + }, + "Moose::Exception::CreateTakesArrayRefOfRoles" : { + "file" : "lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm", + "version" : "2.1405" + }, + "Moose::Exception::CreateTakesHashRefOfAttributes" : { + "file" : "lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm", + "version" : "2.1405" + }, + "Moose::Exception::CreateTakesHashRefOfMethods" : { + "file" : "lib/Moose/Exception/CreateTakesHashRefOfMethods.pm", + "version" : "2.1405" + }, + "Moose::Exception::DefaultToMatchOnTypeMustBeCodeRef" : { + "file" : "lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::DelegationToAClassWhichIsNotLoaded" : { + "file" : "lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm", + "version" : "2.1405" + }, + "Moose::Exception::DelegationToARoleWhichIsNotLoaded" : { + "file" : "lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm", + "version" : "2.1405" + }, + "Moose::Exception::DelegationToATypeWhichIsNotAClass" : { + "file" : "lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::DoesRequiresRoleName" : { + "file" : "lib/Moose/Exception/DoesRequiresRoleName.pm", + "version" : "2.1405" + }, + "Moose::Exception::EnumCalledWithAnArrayRefAndAdditionalArgs" : { + "file" : "lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm", + "version" : "2.1405" + }, + "Moose::Exception::EnumValuesMustBeString" : { + "file" : "lib/Moose/Exception/EnumValuesMustBeString.pm", + "version" : "2.1405" + }, + "Moose::Exception::ExtendsMissingArgs" : { + "file" : "lib/Moose/Exception/ExtendsMissingArgs.pm", + "version" : "2.1405" + }, + "Moose::Exception::HandlesMustBeAHashRef" : { + "file" : "lib/Moose/Exception/HandlesMustBeAHashRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::IllegalInheritedOptions" : { + "file" : "lib/Moose/Exception/IllegalInheritedOptions.pm", + "version" : "2.1405" + }, + "Moose::Exception::IllegalMethodTypeToAddMethodModifier" : { + "file" : "lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm", + "version" : "2.1405" + }, + "Moose::Exception::IncompatibleMetaclassOfSuperclass" : { + "file" : "lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::InitMetaRequiresClass" : { + "file" : "lib/Moose/Exception/InitMetaRequiresClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::InitializeTakesUnBlessedPackageName" : { + "file" : "lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm", + "version" : "2.1405" + }, + "Moose::Exception::InstanceBlessedIntoWrongClass" : { + "file" : "lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::InstanceMustBeABlessedReference" : { + "file" : "lib/Moose/Exception/InstanceMustBeABlessedReference.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidArgPassedToMooseUtilMetaRole" : { + "file" : "lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidArgumentToMethod" : { + "file" : "lib/Moose/Exception/InvalidArgumentToMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidArgumentsToTraitAliases" : { + "file" : "lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidBaseTypeGivenToCreateParameterizedTypeConstraint" : { + "file" : "lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidHandleValue" : { + "file" : "lib/Moose/Exception/InvalidHandleValue.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidHasProvidedInARole" : { + "file" : "lib/Moose/Exception/InvalidHasProvidedInARole.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidNameForType" : { + "file" : "lib/Moose/Exception/InvalidNameForType.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidOverloadOperator" : { + "file" : "lib/Moose/Exception/InvalidOverloadOperator.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidRoleApplication" : { + "file" : "lib/Moose/Exception/InvalidRoleApplication.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidTypeConstraint" : { + "file" : "lib/Moose/Exception/InvalidTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidTypeGivenToCreateParameterizedTypeConstraint" : { + "file" : "lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::InvalidValueForIs" : { + "file" : "lib/Moose/Exception/InvalidValueForIs.pm", + "version" : "2.1405" + }, + "Moose::Exception::IsaDoesNotDoTheRole" : { + "file" : "lib/Moose/Exception/IsaDoesNotDoTheRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::IsaLacksDoesMethod" : { + "file" : "lib/Moose/Exception/IsaLacksDoesMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::LazyAttributeNeedsADefault" : { + "file" : "lib/Moose/Exception/LazyAttributeNeedsADefault.pm", + "version" : "2.1405" + }, + "Moose::Exception::Legacy" : { + "file" : "lib/Moose/Exception/Legacy.pm", + "version" : "2.1405" + }, + "Moose::Exception::MOPAttributeNewNeedsAttributeName" : { + "file" : "lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm", + "version" : "2.1405" + }, + "Moose::Exception::MatchActionMustBeACodeRef" : { + "file" : "lib/Moose/Exception/MatchActionMustBeACodeRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::MessageParameterMustBeCodeRef" : { + "file" : "lib/Moose/Exception/MessageParameterMustBeCodeRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassIsAClassNotASubclassOfGivenMetaclass" : { + "file" : "lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassIsARoleNotASubclassOfGivenMetaclass" : { + "file" : "lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass" : { + "file" : "lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassMustBeASubclassOfMooseMetaClass" : { + "file" : "lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassMustBeASubclassOfMooseMetaRole" : { + "file" : "lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass" : { + "file" : "lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassNotLoaded" : { + "file" : "lib/Moose/Exception/MetaclassNotLoaded.pm", + "version" : "2.1405" + }, + "Moose::Exception::MetaclassTypeIncompatible" : { + "file" : "lib/Moose/Exception/MetaclassTypeIncompatible.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodExpectedAMetaclassObject" : { + "file" : "lib/Moose/Exception/MethodExpectedAMetaclassObject.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodExpectsFewerArgs" : { + "file" : "lib/Moose/Exception/MethodExpectsFewerArgs.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodExpectsMoreArgs" : { + "file" : "lib/Moose/Exception/MethodExpectsMoreArgs.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodModifierNeedsMethodName" : { + "file" : "lib/Moose/Exception/MethodModifierNeedsMethodName.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodNameConflictInRoles" : { + "file" : "lib/Moose/Exception/MethodNameConflictInRoles.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodNameNotFoundInInheritanceHierarchy" : { + "file" : "lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm", + "version" : "2.1405" + }, + "Moose::Exception::MethodNameNotGiven" : { + "file" : "lib/Moose/Exception/MethodNameNotGiven.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustDefineAMethodName" : { + "file" : "lib/Moose/Exception/MustDefineAMethodName.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustDefineAnAttributeName" : { + "file" : "lib/Moose/Exception/MustDefineAnAttributeName.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustDefineAnOverloadOperator" : { + "file" : "lib/Moose/Exception/MustDefineAnOverloadOperator.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustHaveAtLeastOneValueToEnumerate" : { + "file" : "lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustPassAHashOfOptions" : { + "file" : "lib/Moose/Exception/MustPassAHashOfOptions.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustPassAMooseMetaRoleInstanceOrSubclass" : { + "file" : "lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustPassAPackageNameOrAnExistingClassMOPPackageInstance" : { + "file" : "lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustPassEvenNumberOfArguments" : { + "file" : "lib/Moose/Exception/MustPassEvenNumberOfArguments.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustPassEvenNumberOfAttributeOptions" : { + "file" : "lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustProvideANameForTheAttribute" : { + "file" : "lib/Moose/Exception/MustProvideANameForTheAttribute.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSpecifyAtleastOneMethod" : { + "file" : "lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSpecifyAtleastOneRole" : { + "file" : "lib/Moose/Exception/MustSpecifyAtleastOneRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant" : { + "file" : "lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyAClassMOPAttributeInstance" : { + "file" : "lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyADelegateToMethod" : { + "file" : "lib/Moose/Exception/MustSupplyADelegateToMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyAMetaclass" : { + "file" : "lib/Moose/Exception/MustSupplyAMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyAMooseMetaAttributeInstance" : { + "file" : "lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyAnAccessorTypeToConstructWith" : { + "file" : "lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyAnAttributeToConstructWith" : { + "file" : "lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyArrayRefAsCurriedArguments" : { + "file" : "lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm", + "version" : "2.1405" + }, + "Moose::Exception::MustSupplyPackageNameAndName" : { + "file" : "lib/Moose/Exception/MustSupplyPackageNameAndName.pm", + "version" : "2.1405" + }, + "Moose::Exception::NeedsTypeConstraintUnionForTypeCoercionUnion" : { + "file" : "lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm", + "version" : "2.1405" + }, + "Moose::Exception::NeitherAttributeNorAttributeNameIsGiven" : { + "file" : "lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm", + "version" : "2.1405" + }, + "Moose::Exception::NeitherClassNorClassNameIsGiven" : { + "file" : "lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm", + "version" : "2.1405" + }, + "Moose::Exception::NeitherRoleNorRoleNameIsGiven" : { + "file" : "lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm", + "version" : "2.1405" + }, + "Moose::Exception::NeitherTypeNorTypeNameIsGiven" : { + "file" : "lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoAttributeFoundInSuperClass" : { + "file" : "lib/Moose/Exception/NoAttributeFoundInSuperClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoBodyToInitializeInAnAbstractBaseClass" : { + "file" : "lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoCasesMatched" : { + "file" : "lib/Moose/Exception/NoCasesMatched.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoConstraintCheckForTypeConstraint" : { + "file" : "lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoDestructorClassSpecified" : { + "file" : "lib/Moose/Exception/NoDestructorClassSpecified.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoImmutableTraitSpecifiedForClass" : { + "file" : "lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::NoParentGivenToSubtype" : { + "file" : "lib/Moose/Exception/NoParentGivenToSubtype.pm", + "version" : "2.1405" + }, + "Moose::Exception::OnlyInstancesCanBeCloned" : { + "file" : "lib/Moose/Exception/OnlyInstancesCanBeCloned.pm", + "version" : "2.1405" + }, + "Moose::Exception::OperatorIsRequired" : { + "file" : "lib/Moose/Exception/OperatorIsRequired.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadConflictInSummation" : { + "file" : "lib/Moose/Exception/OverloadConflictInSummation.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadRequiresAMetaClass" : { + "file" : "lib/Moose/Exception/OverloadRequiresAMetaClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadRequiresAMetaMethod" : { + "file" : "lib/Moose/Exception/OverloadRequiresAMetaMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadRequiresAMetaOverload" : { + "file" : "lib/Moose/Exception/OverloadRequiresAMetaOverload.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadRequiresAMethodNameOrCoderef" : { + "file" : "lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadRequiresAnOperator" : { + "file" : "lib/Moose/Exception/OverloadRequiresAnOperator.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverloadRequiresNamesForCoderef" : { + "file" : "lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverrideConflictInComposition" : { + "file" : "lib/Moose/Exception/OverrideConflictInComposition.pm", + "version" : "2.1405" + }, + "Moose::Exception::OverrideConflictInSummation" : { + "file" : "lib/Moose/Exception/OverrideConflictInSummation.pm", + "version" : "2.1405" + }, + "Moose::Exception::PackageDoesNotUseMooseExporter" : { + "file" : "lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm", + "version" : "2.1405" + }, + "Moose::Exception::PackageNameAndNameParamsNotGivenToWrap" : { + "file" : "lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm", + "version" : "2.1405" + }, + "Moose::Exception::PackagesAndModulesAreNotCachable" : { + "file" : "lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm", + "version" : "2.1405" + }, + "Moose::Exception::ParameterIsNotSubtypeOfParent" : { + "file" : "lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm", + "version" : "2.1405" + }, + "Moose::Exception::ReferencesAreNotAllowedAsDefault" : { + "file" : "lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm", + "version" : "2.1405" + }, + "Moose::Exception::RequiredAttributeLacksInitialization" : { + "file" : "lib/Moose/Exception/RequiredAttributeLacksInitialization.pm", + "version" : "2.1405" + }, + "Moose::Exception::RequiredAttributeNeedsADefault" : { + "file" : "lib/Moose/Exception/RequiredAttributeNeedsADefault.pm", + "version" : "2.1405" + }, + "Moose::Exception::RequiredMethodsImportedByClass" : { + "file" : "lib/Moose/Exception/RequiredMethodsImportedByClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::RequiredMethodsNotImplementedByClass" : { + "file" : "lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::Attribute" : { + "file" : "lib/Moose/Exception/Role/Attribute.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::AttributeName" : { + "file" : "lib/Moose/Exception/Role/AttributeName.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::Class" : { + "file" : "lib/Moose/Exception/Role/Class.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::EitherAttributeOrAttributeName" : { + "file" : "lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::Instance" : { + "file" : "lib/Moose/Exception/Role/Instance.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::InstanceClass" : { + "file" : "lib/Moose/Exception/Role/InstanceClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::InvalidAttributeOptions" : { + "file" : "lib/Moose/Exception/Role/InvalidAttributeOptions.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::Method" : { + "file" : "lib/Moose/Exception/Role/Method.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::ParamsHash" : { + "file" : "lib/Moose/Exception/Role/ParamsHash.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::Role" : { + "file" : "lib/Moose/Exception/Role/Role.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::RoleForCreate" : { + "file" : "lib/Moose/Exception/Role/RoleForCreate.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::RoleForCreateMOPClass" : { + "file" : "lib/Moose/Exception/Role/RoleForCreateMOPClass.pm", + "version" : "2.1405" + }, + "Moose::Exception::Role::TypeConstraint" : { + "file" : "lib/Moose/Exception/Role/TypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::RoleDoesTheExcludedRole" : { + "file" : "lib/Moose/Exception/RoleDoesTheExcludedRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::RoleExclusionConflict" : { + "file" : "lib/Moose/Exception/RoleExclusionConflict.pm", + "version" : "2.1405" + }, + "Moose::Exception::RoleNameRequired" : { + "file" : "lib/Moose/Exception/RoleNameRequired.pm", + "version" : "2.1405" + }, + "Moose::Exception::RoleNameRequiredForMooseMetaRole" : { + "file" : "lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::RolesDoNotSupportAugment" : { + "file" : "lib/Moose/Exception/RolesDoNotSupportAugment.pm", + "version" : "2.1405" + }, + "Moose::Exception::RolesDoNotSupportExtends" : { + "file" : "lib/Moose/Exception/RolesDoNotSupportExtends.pm", + "version" : "2.1405" + }, + "Moose::Exception::RolesDoNotSupportInner" : { + "file" : "lib/Moose/Exception/RolesDoNotSupportInner.pm", + "version" : "2.1405" + }, + "Moose::Exception::RolesDoNotSupportRegexReferencesForMethodModifiers" : { + "file" : "lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm", + "version" : "2.1405" + }, + "Moose::Exception::RolesInCreateTakesAnArrayRef" : { + "file" : "lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::RolesListMustBeInstancesOfMooseMetaRole" : { + "file" : "lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm", + "version" : "2.1405" + }, + "Moose::Exception::SingleParamsToNewMustBeHashRef" : { + "file" : "lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::TriggerMustBeACodeRef" : { + "file" : "lib/Moose/Exception/TriggerMustBeACodeRef.pm", + "version" : "2.1405" + }, + "Moose::Exception::TypeConstraintCannotBeUsedForAParameterizableType" : { + "file" : "lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm", + "version" : "2.1405" + }, + "Moose::Exception::TypeConstraintIsAlreadyCreated" : { + "file" : "lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm", + "version" : "2.1405" + }, + "Moose::Exception::TypeParameterMustBeMooseMetaType" : { + "file" : "lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm", + "version" : "2.1405" + }, + "Moose::Exception::UnableToCanonicalizeHandles" : { + "file" : "lib/Moose/Exception/UnableToCanonicalizeHandles.pm", + "version" : "2.1405" + }, + "Moose::Exception::UnableToCanonicalizeNonRolePackage" : { + "file" : "lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm", + "version" : "2.1405" + }, + "Moose::Exception::UnableToRecognizeDelegateMetaclass" : { + "file" : "lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm", + "version" : "2.1405" + }, + "Moose::Exception::UndefinedHashKeysPassedToMethod" : { + "file" : "lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm", + "version" : "2.1405" + }, + "Moose::Exception::UnionCalledWithAnArrayRefAndAdditionalArgs" : { + "file" : "lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm", + "version" : "2.1405" + }, + "Moose::Exception::UnionTakesAtleastTwoTypeNames" : { + "file" : "lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm", + "version" : "2.1405" + }, + "Moose::Exception::ValidationFailedForInlineTypeConstraint" : { + "file" : "lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::ValidationFailedForTypeConstraint" : { + "file" : "lib/Moose/Exception/ValidationFailedForTypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Exception::WrapTakesACodeRefToBless" : { + "file" : "lib/Moose/Exception/WrapTakesACodeRefToBless.pm", + "version" : "2.1405" + }, + "Moose::Exception::WrongTypeConstraintGiven" : { + "file" : "lib/Moose/Exception/WrongTypeConstraintGiven.pm", + "version" : "2.1405" + }, + "Moose::Exporter" : { + "file" : "lib/Moose/Exporter.pm", + "version" : "2.1405" + }, + "Moose::Intro" : { + "file" : "lib/Moose/Intro.pod", + "version" : "2.1405" + }, + "Moose::Manual" : { + "file" : "lib/Moose/Manual.pod", + "version" : "2.1405" + }, + "Moose::Manual::Attributes" : { + "file" : "lib/Moose/Manual/Attributes.pod", + "version" : "2.1405" + }, + "Moose::Manual::BestPractices" : { + "file" : "lib/Moose/Manual/BestPractices.pod", + "version" : "2.1405" + }, + "Moose::Manual::Classes" : { + "file" : "lib/Moose/Manual/Classes.pod", + "version" : "2.1405" + }, + "Moose::Manual::Concepts" : { + "file" : "lib/Moose/Manual/Concepts.pod", + "version" : "2.1405" + }, + "Moose::Manual::Construction" : { + "file" : "lib/Moose/Manual/Construction.pod", + "version" : "2.1405" + }, + "Moose::Manual::Contributing" : { + "file" : "lib/Moose/Manual/Contributing.pod", + "version" : "2.1405" + }, + "Moose::Manual::Delegation" : { + "file" : "lib/Moose/Manual/Delegation.pod", + "version" : "2.1405" + }, + "Moose::Manual::Delta" : { + "file" : "lib/Moose/Manual/Delta.pod", + "version" : "2.1405" + }, + "Moose::Manual::Exceptions" : { + "file" : "lib/Moose/Manual/Exceptions.pod", + "version" : "2.1405" + }, + "Moose::Manual::Exceptions::Manifest" : { + "file" : "lib/Moose/Manual/Exceptions/Manifest.pod", + "version" : "2.1405" + }, + "Moose::Manual::FAQ" : { + "file" : "lib/Moose/Manual/FAQ.pod", + "version" : "2.1405" + }, + "Moose::Manual::MOP" : { + "file" : "lib/Moose/Manual/MOP.pod", + "version" : "2.1405" + }, + "Moose::Manual::MethodModifiers" : { + "file" : "lib/Moose/Manual/MethodModifiers.pod", + "version" : "2.1405" + }, + "Moose::Manual::MooseX" : { + "file" : "lib/Moose/Manual/MooseX.pod", + "version" : "2.1405" + }, + "Moose::Manual::Resources" : { + "file" : "lib/Moose/Manual/Resources.pod", + "version" : "2.1405" + }, + "Moose::Manual::Roles" : { + "file" : "lib/Moose/Manual/Roles.pod", + "version" : "2.1405" + }, + "Moose::Manual::Support" : { + "file" : "lib/Moose/Manual/Support.pod", + "version" : "2.1405" + }, + "Moose::Manual::Types" : { + "file" : "lib/Moose/Manual/Types.pod", + "version" : "2.1405" + }, + "Moose::Manual::Unsweetened" : { + "file" : "lib/Moose/Manual/Unsweetened.pod", + "version" : "2.1405" + }, + "Moose::Meta::Attribute" : { + "file" : "lib/Moose/Meta/Attribute.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Custom::Moose" : { + "file" : "lib/Moose/Meta/Attribute.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native" : { + "file" : "lib/Moose/Meta/Attribute/Native.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::Array" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/Array.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::Bool" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/Bool.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::Code" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/Code.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::Counter" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/Counter.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::Hash" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/Hash.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::Number" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/Number.pm", + "version" : "2.1405" + }, + "Moose::Meta::Attribute::Native::Trait::String" : { + "file" : "lib/Moose/Meta/Attribute/Native/Trait/String.pm", + "version" : "2.1405" + }, + "Moose::Meta::Class" : { + "file" : "lib/Moose/Meta/Class.pm", + "version" : "2.1405" + }, + "Moose::Meta::Instance" : { + "file" : "lib/Moose/Meta/Instance.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method" : { + "file" : "lib/Moose/Meta/Method.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Accessor" : { + "file" : "lib/Moose/Meta/Method/Accessor.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Augmented" : { + "file" : "lib/Moose/Meta/Method/Augmented.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Constructor" : { + "file" : "lib/Moose/Meta/Method/Constructor.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Delegation" : { + "file" : "lib/Moose/Meta/Method/Delegation.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Destructor" : { + "file" : "lib/Moose/Meta/Method/Destructor.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Meta" : { + "file" : "lib/Moose/Meta/Method/Meta.pm", + "version" : "2.1405" + }, + "Moose::Meta::Method::Overridden" : { + "file" : "lib/Moose/Meta/Method/Overridden.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role" : { + "file" : "lib/Moose/Meta/Role.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Application" : { + "file" : "lib/Moose/Meta/Role/Application.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Application::RoleSummation" : { + "file" : "lib/Moose/Meta/Role/Application/RoleSummation.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Application::ToClass" : { + "file" : "lib/Moose/Meta/Role/Application/ToClass.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Application::ToInstance" : { + "file" : "lib/Moose/Meta/Role/Application/ToInstance.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Application::ToRole" : { + "file" : "lib/Moose/Meta/Role/Application/ToRole.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Attribute" : { + "file" : "lib/Moose/Meta/Role/Attribute.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Composite" : { + "file" : "lib/Moose/Meta/Role/Composite.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Method" : { + "file" : "lib/Moose/Meta/Role/Method.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Method::Conflicting" : { + "file" : "lib/Moose/Meta/Role/Method/Conflicting.pm", + "version" : "2.1405" + }, + "Moose::Meta::Role::Method::Required" : { + "file" : "lib/Moose/Meta/Role/Method/Required.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeCoercion" : { + "file" : "lib/Moose/Meta/TypeCoercion.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeCoercion::Union" : { + "file" : "lib/Moose/Meta/TypeCoercion/Union.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint" : { + "file" : "lib/Moose/Meta/TypeConstraint.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Class" : { + "file" : "lib/Moose/Meta/TypeConstraint/Class.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::DuckType" : { + "file" : "lib/Moose/Meta/TypeConstraint/DuckType.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Enum" : { + "file" : "lib/Moose/Meta/TypeConstraint/Enum.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Parameterizable" : { + "file" : "lib/Moose/Meta/TypeConstraint/Parameterizable.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Parameterized" : { + "file" : "lib/Moose/Meta/TypeConstraint/Parameterized.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Registry" : { + "file" : "lib/Moose/Meta/TypeConstraint/Registry.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Role" : { + "file" : "lib/Moose/Meta/TypeConstraint/Role.pm", + "version" : "2.1405" + }, + "Moose::Meta::TypeConstraint::Union" : { + "file" : "lib/Moose/Meta/TypeConstraint/Union.pm", + "version" : "2.1405" + }, + "Moose::Object" : { + "file" : "lib/Moose/Object.pm", + "version" : "2.1405" + }, + "Moose::Role" : { + "file" : "lib/Moose/Role.pm", + "version" : "2.1405" + }, + "Moose::Spec::Role" : { + "file" : "lib/Moose/Spec/Role.pod", + "version" : "2.1405" + }, + "Moose::Unsweetened" : { + "file" : "lib/Moose/Unsweetened.pod", + "version" : "2.1405" + }, + "Moose::Util" : { + "file" : "lib/Moose/Util.pm", + "version" : "2.1405" + }, + "Moose::Util::MetaRole" : { + "file" : "lib/Moose/Util/MetaRole.pm", + "version" : "2.1405" + }, + "Moose::Util::TypeConstraints" : { + "file" : "lib/Moose/Util/TypeConstraints.pm", + "version" : "2.1405" + }, + "Test::Moose" : { + "file" : "lib/Test/Moose.pm", + "version" : "2.1405" + }, + "metaclass" : { + "file" : "lib/metaclass.pm", + "version" : "2.1405" + }, + "oose" : { + "file" : "lib/oose.pm", + "version" : "2.1405" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-moose@rt.cpan.org", + "web" : "https://rt.cpan.org/Dist/Display.html?Name=Moose" + }, + "homepage" : "http://moose.perl.org/", + "repository" : { + "type" : "git", + "url" : "git://github.com/moose/Moose.git", + "web" : "https://github.com/moose/Moose" + }, + "x_IRC" : "irc://irc.perl.org/#moose", + "x_MailingList" : "http://lists.perl.org/list/moose.html" + }, + "version" : "2.1405", + "x_Dist_Zilla" : { + "perl" : { + "version" : "5.020002" + }, + "plugins" : [ + { + "class" : "Dist::Zilla::Plugin::EnsurePrereqsInstalled", + "name" : "EnsurePrereqsInstalled", + "version" : "0.008" + }, + { + "class" : "Dist::Zilla::Plugin::Git::GatherDir", + "config" : { + "Dist::Zilla::Plugin::GatherDir" : { + "exclude_filename" : [ + "Makefile.PL", + "LICENSE" + ], + "exclude_match" : [ + "^t/recipes/(?!basics_genome_overloadingsubtypesandcoercion)" + ], + "follow_symlinks" : "0", + "include_dotfiles" : "0", + "prefix" : "", + "prune_directory" : [], + "root" : "." + }, + "Dist::Zilla::Plugin::Git::GatherDir" : { + "include_untracked" : "0" + } + }, + "name" : "Git::GatherDir", + "version" : "2.034" + }, + { + "class" : "Dist::Zilla::Plugin::MetaYAML", + "name" : "MetaYAML", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::MetaJSON", + "name" : "MetaJSON", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::License", + "name" : "License", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::ExecDir", + "name" : "ExecDir", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::ShareDir", + "name" : "ShareDir", + "version" : "5.037" + }, + { + "class" : "inc::MakeMaker", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : "9" + } + }, + "name" : "=inc::MakeMaker", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::Manifest", + "name" : "Manifest", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::MetaConfig", + "name" : "MetaConfig", + "version" : "5.037" + }, + { + "class" : "inc::SimpleAuthority", + "name" : "=inc::SimpleAuthority", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::MetaResources", + "name" : "MetaResources", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FileFinder::ByName", + "name" : "PodModules", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FileFinder::Filter", + "name" : "ModulesSansPod", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FileFinder::Filter", + "name" : "VersionedModules", + "version" : "5.037" + }, + { + "class" : "inc::SimpleProvides", + "name" : "=inc::SimpleProvides", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::MetaProvides::Package", + "config" : { + "Dist::Zilla::Plugin::MetaProvides::Package" : { + "finder" : [ + "ModulesSansPod" + ], + "finder_objects" : [ + { + "class" : "Dist::Zilla::Plugin::FileFinder::Filter", + "name" : "ModulesSansPod", + "version" : "5.037" + } + ] + }, + "Dist::Zilla::Role::MetaProvider::Provider" : { + "inherit_missing" : "1", + "inherit_version" : "1", + "meta_noindex" : "1" + } + }, + "name" : "MetaProvides::Package", + "version" : "2.003001" + }, + { + "class" : "Dist::Zilla::Plugin::MetaNoIndex", + "name" : "MetaNoIndex", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Contributors", + "config" : { + "Dist::Zilla::Plugin::Git::Contributors" : { + "include_authors" : "0", + "include_releaser" : "1", + "order_by" : "name", + "paths" : [] + } + }, + "name" : "Git::Contributors", + "version" : "0.011" + }, + { + "class" : "Dist::Zilla::Plugin::SurgicalPodWeaver", + "config" : { + "Dist::Zilla::Plugin::PodWeaver" : { + "finder" : [ + ":InstallModules", + ":ExecFiles" + ], + "plugins" : [ + { + "class" : "Pod::Weaver::Plugin::EnsurePod5", + "name" : "@CorePrep/EnsurePod5", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Plugin::H1Nester", + "name" : "@CorePrep/H1Nester", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Plugin::SingleEncoding", + "name" : "@Default/SingleEncoding", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Name", + "name" : "@Default/Name", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Version", + "name" : "@Default/Version", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "@Default/prelude", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "SYNOPSIS", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "DESCRIPTION", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "OVERVIEW", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "ATTRIBUTES", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "METHODS", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Collect", + "name" : "FUNCTIONS", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Leftovers", + "name" : "@Default/Leftovers", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "@Default/postlude", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Authors", + "name" : "@Default/Authors", + "version" : "4.011" + }, + { + "class" : "Pod::Weaver::Section::Legal", + "name" : "@Default/Legal", + "version" : "4.011" + } + ] + } + }, + "name" : "SurgicalPodWeaver", + "version" : "0.0023" + }, + { + "class" : "Dist::Zilla::Plugin::RewriteVersion", + "name" : "RewriteVersion", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Describe", + "name" : "Git::Describe", + "version" : "0.005" + }, + { + "class" : "inc::ExtractInlineTests", + "name" : "=inc::ExtractInlineTests", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::PromptIfStale", + "config" : { + "Dist::Zilla::Plugin::PromptIfStale" : { + "check_all_plugins" : "1", + "check_all_prereqs" : "1", + "modules" : [], + "phase" : "release", + "skip" : [] + } + }, + "name" : "PromptIfStale", + "version" : "0.044" + }, + { + "class" : "Dist::Zilla::Plugin::Test::EOL", + "config" : { + "Dist::Zilla::Plugin::Test::EOL" : { + "filename" : "xt/author/eol.t", + "finder" : [ + ":InstallModules", + ":ExecFiles", + ":TestFiles" + ], + "trailing_whitespace" : "1" + } + }, + "name" : "Test::EOL", + "version" : "0.18" + }, + { + "class" : "Dist::Zilla::Plugin::PodSyntaxTests", + "name" : "PodSyntaxTests", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Test::NoTabs", + "config" : { + "Dist::Zilla::Plugin::Test::NoTabs" : { + "filename" : "xt/author/no-tabs.t", + "finder" : [ + ":InstallModules", + ":ExecFiles", + ":TestFiles" + ] + } + }, + "name" : "Test::NoTabs", + "version" : "0.15" + }, + { + "class" : "Dist::Zilla::Plugin::MetaTests", + "name" : "MetaTests", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Kwalitee", + "config" : { + "Dist::Zilla::Plugin::Test::Kwalitee" : { + "filename" : "xt/release/kwalitee.t", + "skiptest" : [ + "use_strict" + ] + } + }, + "name" : "Test::Kwalitee", + "version" : "2.11" + }, + { + "class" : "Dist::Zilla::Plugin::MojibakeTests", + "name" : "MojibakeTests", + "version" : "0.7" + }, + { + "class" : "Dist::Zilla::Plugin::RunExtraTests", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : "9" + } + }, + "name" : "RunExtraTests", + "version" : "0.027" + }, + { + "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", + "name" : "Test::ReportPrereqs", + "version" : "0.021" + }, + { + "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes", + "name" : "Test::CPAN::Changes", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Compile", + "config" : { + "Dist::Zilla::Plugin::Test::Compile" : { + "bail_out_on_fail" : "1", + "fail_on_warning" : "author", + "fake_home" : "0", + "filename" : "xt/release/00-compile.t", + "module_finder" : [ + ":InstallModules" + ], + "needs_display" : "0", + "phase" : "develop", + "script_finder" : [ + ":ExecFiles" + ], + "skips" : [ + "^Class::MOP::Attribute$", + "^Class::MOP::Class$", + "^Class::MOP::Method::Accessor$", + "^Class::MOP::Method::Constructor$", + "^Class::MOP::Method::Inlined$", + "^Class::MOP::Method::Wrapped$", + "^Class::MOP::Mixin::HasAttributes$", + "^Class::MOP::Module$", + "^Class::MOP::Package$", + "^Moose::Meta::Attribute$", + "^Moose::Meta::Attribute::Native$", + "^Moose::Meta::Mixin::AttributeCore$", + "^Moose::Meta::Role::Attribute$", + "^Moose::Meta::TypeConstraint::Class$", + "^Moose::Meta::TypeConstraint::DuckType$", + "^Moose::Meta::TypeConstraint::Enum$", + "^Moose::Meta::TypeConstraint::Parameterizable$", + "^Moose::Meta::TypeConstraint::Parameterized$", + "^Moose::Meta::TypeConstraint::Role$", + "^Moose::Meta::TypeConstraint::Union$" + ] + } + }, + "name" : "Test::Compile", + "version" : "2.053" + }, + { + "class" : "inc::CheckReleaseType", + "name" : "=inc::CheckReleaseType", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::CheckVersionIncrement", + "name" : "CheckVersionIncrement", + "version" : "0.121750" + }, + { + "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", + "name" : "CheckChangesHasContent", + "version" : "0.008" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "runtime", + "type" : "requires" + } + }, + "name" : "Prereqs", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "test", + "type" : "requires" + } + }, + "name" : "TestRequires", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "configure", + "type" : "requires" + } + }, + "name" : "ConfigureRequires", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs::AuthorDeps", + "name" : "Prereqs::AuthorDeps", + "version" : "0.004" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "develop", + "type" : "requires" + } + }, + "name" : "DevelopRequires", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "runtime", + "type" : "suggests" + } + }, + "name" : "RuntimeSuggests", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Conflicts", + "name" : "Conflicts", + "version" : "0.17" + }, + { + "class" : "Dist::Zilla::Plugin::Test::CheckBreaks", + "config" : { + "Dist::Zilla::Plugin::Test::CheckBreaks" : { + "conflicts_module" : "Moose::Conflicts" + }, + "Dist::Zilla::Role::ModuleMetadata" : { + "Module::Metadata" : "1.000026", + "version" : "0.002" + } + }, + "name" : "Test::CheckBreaks", + "version" : "0.012" + }, + { + "class" : "inc::CheckAuthorDeps", + "name" : "=inc::CheckAuthorDeps", + "version" : null + }, + { + "class" : "inc::CheckDelta", + "name" : "=inc::CheckDelta", + "version" : null + }, + { + "class" : "inc::GitUpToDate", + "name" : "=inc::GitUpToDate", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::Git::Remote::Check", + "name" : "Git::Remote::Check", + "version" : "0.1.2" + }, + { + "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch", + "config" : { + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "Git::CheckFor::CorrectBranch", + "version" : "0.013" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Check", + "config" : { + "Dist::Zilla::Plugin::Git::Check" : { + "untracked_files" : "die" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "Git::Check", + "version" : "2.034" + }, + { + "class" : "Dist::Zilla::Plugin::TestRelease", + "name" : "TestRelease", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::UploadToCPAN", + "name" : "UploadToCPAN", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease", + "config" : { + "Dist::Zilla::Plugin::CopyFilesFromRelease" : { + "filename" : [ + "Changes", + "LICENSE" + ], + "match" : [] + } + }, + "name" : "CopyFilesFromRelease", + "version" : "0.005" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "%N-%v%t%n%n%c", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "Changes", + "LICENSE" + ], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "release snapshot", + "version" : "2.034" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Tag", + "config" : { + "Dist::Zilla::Plugin::Git::Tag" : { + "branch" : null, + "signed" : 0, + "tag" : "2.1405", + "tag_format" : "%v", + "tag_message" : "%v%t", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "Git::Tag", + "version" : "2.034" + }, + { + "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease", + "name" : "BumpVersionAfterRelease", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::NextRelease", + "name" : "NextRelease", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "increment version after release", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "Changes" + ], + "allow_dirty_match" : [ + "(?^u:^lib/.*\\.pm$)" + ], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "increment version", + "version" : "2.034" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Push", + "config" : { + "Dist::Zilla::Plugin::Git::Push" : { + "push_to" : [ + "origin" + ], + "remotes_must_exist" : 1 + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "Git::Push", + "version" : "2.034" + }, + { + "class" : "Dist::Zilla::Plugin::Run::AfterRelease", + "config" : { + "Dist::Zilla::Plugin::Run::Role::Runner" : { + "fatal_errors" : 1, + "quiet" : 0, + "run" : [ + "git checkout master", + "git merge --ff-only stable/2.14", + "git push" + ] + } + }, + "name" : "Run::AfterRelease", + "version" : "0.038" + }, + { + "class" : "inc::GenerateDocs", + "name" : "=inc::GenerateDocs", + "version" : null + }, + { + "class" : "inc::Clean", + "name" : "=inc::Clean", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::ConfirmRelease", + "name" : "ConfirmRelease", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":InstallModules", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":IncModules", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":TestFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ExecFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ShareFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":MainModule", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":AllFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":NoFiles", + "version" : "5.037" + } + ], + "zilla" : { + "class" : "Dist::Zilla::Dist::Builder", + "config" : { + "is_trial" : "0" + }, + "version" : "5.037" + } + }, + "x_authority" : "cpan:STEVAN", + "x_breaks" : { + "Catalyst" : "<= 5.90049999", + "Config::MVP" : "<= 2.200004", + "Devel::REPL" : "<= 1.003020", + "Dist::Zilla::Plugin::Git" : "<= 2.016", + "Fey" : "<= 0.36", + "Fey::ORM" : "<= 0.42", + "File::ChangeNotify" : "<= 0.15", + "HTTP::Throwable" : "<= 0.017", + "KiokuDB" : "<= 0.51", + "Markdent" : "<= 0.16", + "Mason" : "<= 2.18", + "MooseX::ABC" : "<= 0.05", + "MooseX::Aliases" : "<= 0.08", + "MooseX::AlwaysCoerce" : "<= 0.13", + "MooseX::App" : "<= 1.22", + "MooseX::Attribute::Deflator" : "<= 2.1.7", + "MooseX::Attribute::Dependent" : "<= 1.1.0", + "MooseX::Attribute::Prototype" : "<= 0.10", + "MooseX::AttributeHelpers" : "<= 0.22", + "MooseX::AttributeIndexes" : "<= 1.0.0", + "MooseX::AttributeInflate" : "<= 0.02", + "MooseX::CascadeClearing" : "<= 0.03", + "MooseX::ClassAttribute" : "<= 0.26", + "MooseX::Constructor::AllErrors" : "<= 0.021", + "MooseX::Declare" : "<= 0.35", + "MooseX::FollowPBP" : "<= 0.02", + "MooseX::Getopt" : "<= 0.56", + "MooseX::InstanceTracking" : "<= 0.04", + "MooseX::LazyRequire" : "<= 0.06", + "MooseX::Meta::Attribute::Index" : "<= 0.04", + "MooseX::Meta::Attribute::Lvalue" : "<= 0.05", + "MooseX::Method::Signatures" : "<= 0.44", + "MooseX::MethodAttributes" : "<= 0.22", + "MooseX::NonMoose" : "<= 0.24", + "MooseX::Object::Pluggable" : "<= 0.0011", + "MooseX::POE" : "<= 0.214", + "MooseX::Params::Validate" : "<= 0.05", + "MooseX::PrivateSetters" : "<= 0.03", + "MooseX::Role::Cmd" : "<= 0.06", + "MooseX::Role::Parameterized" : "<= 1.00", + "MooseX::Role::WithOverloading" : "<= 0.14", + "MooseX::Runnable" : "<= 0.03", + "MooseX::Scaffold" : "<= 0.05", + "MooseX::SemiAffordanceAccessor" : "<= 0.05", + "MooseX::SetOnce" : "<= 0.100473", + "MooseX::Singleton" : "<= 0.25", + "MooseX::SlurpyConstructor" : "<= 1.1", + "MooseX::Storage" : "<= 0.42", + "MooseX::StrictConstructor" : "<= 0.12", + "MooseX::Traits" : "<= 0.11", + "MooseX::Types" : "<= 0.19", + "MooseX::Types::Parameterizable" : "<= 0.05", + "MooseX::Types::Set::Object" : "<= 0.03", + "MooseX::Types::Signal" : "<= 1.101930", + "MooseX::UndefTolerant" : "<= 0.11", + "PRANG" : "<= 0.14", + "Pod::Elemental" : "<= 0.093280", + "Pod::Weaver" : "<= 3.101638", + "Reaction" : "<= 0.002003", + "Test::Able" : "<= 0.10", + "Test::CleanNamespaces" : "<= 0.03", + "Test::Moose::More" : "<= 0.022", + "Test::TempDir" : "<= 0.05", + "Throwable" : "<= 0.102080", + "namespace::autoclean" : "<= 0.08" + }, + "x_contributors" : [ + "Aankhen <aankhen@gmail.com>", + "Adam J. Foxson <fhoxh@pobox.com>", + "Adam Kennedy <adamk@cpan.org>", + "Ævar Arnfjörð Bjarmason <avarab@gmail.com>", + "Anders Nor Berle <berle@cpan.org>", + "Ansgar Burchardt <ansgar@43-1.org>", + "Aran Clary Deltac <bluefeet@cpan.org>", + "Ash Berlin <ash@cpan.org>", + "A. Sinan Unur <nanis@cpan.org>", + "Brad Bowman <bsb@strategicdata.com.au>", + "Brendan Byrd <Perl@ResonatorSoft.org>", + "Brian Manning <elspicyjack@gmail.com>", + "Chad Granum <chad.granum@dreamhost.com>", + "Chankey Pathak <chankey007@gmail.com>", + "Chia-liang Kao <clkao@clkao.org>", + "Chip <chip@pobox.com>", + "Christian Hansen <chansen@cpan.org>", + "Christopher J. Madsen <perl@cjmweb.net>", + "Chris Weyl <cweyl@alumni.drew.edu>", + "chromatic <chromatic@wgz.org>", + "Cory Watson <github@onemogin.com>", + "Curtis Jewell <perl@csjewell.fastmail.us>", + "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>", + "Daisuke Maki (lestrrat) <daisuke@endeworks.jp>", + "Dan Dascalescu <ddascaNOSPAMlescu@gmail.com>", + "Dann <techmemo@gmail.com>", + "Dave Romano <dave.romano@ionzero.com>", + "David Leadbeater <dgl@dgl.cx>", + "David Steinbrunner <dsteinbrunner@MountainBook-Pro.local>", + "Dylan William Hardison <dylan@hardison.net>", + "Eric Wilhelm <ewilhelm@cpan.org>", + "Evan Carroll <evan@dealermade.com>", + "franck cuny <franck@lumberjaph.net>", + "Frew Schmidt <frioux@gmail.com>", + "Gerda Shank <gerda.shank@gmail.com>", + "gfx <gfuji@cpan.org>", + "Graham Knop <haarg@haarg.org>", + "gregor herrmann <gregoa@debian.org>", + "Guillermo Roditi <groditi@gmail.com>", + "hakim <hakim.cassimally@gmail.com>", + "Henry Van Styn <vanstyn@intellitree.com>", + "James Marca <james@activimetrics.com>", + "Jason May <jason.a.may@gmail.com>", + "Jay Allen <jay@endevver.com>", + "Jay Hannah <jay@jays.net>", + "Jay Kuri <jayk@jay-kuris-macbook.local>", + "Jeff Bisbee <jbisbee@biz.(none)>", + "Jesse Vincent <jesse@bestpractical.com>", + "Jess Robinson <cpan@desert-island.me.uk>", + "joel <joel@fysh.org>", + "John Douglas Porter <jdporter@cpan.org>", + "John Goulah <jgoulah@cpan.org>", + "John Napiorkowski <jjnapiork@cpan.org>", + "Jonathan Rockway <jon@jrock.us>", + "Justin DeVuyst <justin@devuyst.com>", + "Justin Hunter <justin.d.hunter@gmail.com>", + "Kent Fredric <kentnl@cpan.org>", + "Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>", + "Leon Brocard <acme@astray.com>", + "Marcel Grünauer <hanekomu@gmail.com>", + "Marc Mims <marc@questright.com>", + "Marcus Ramberg <marcus@nordaaker.com>", + "Mark Allen <mrallen1@yahoo.com>", + "Mark A. Stratman <stratman@gmail.com>", + "Mark Fowler <mark@twoshortplanks.com>", + "Mateu X Hunter <hunter@missoula.org>", + "Matthew Horsfall <wolfsage@gmail.com>", + "matthof <rmhofmann@gmail.com>", + "Matt Kraai <kraai@ftbfs.org>", + "Michael LaGrasta <michael@lagrasta.com>", + "Michael Rykov <mrykov@gmail.com>", + "Michael Schout <mschout@gkg.net>", + "Mike Whitaker <mike@altrion.org>", + "Moritz Onken <onken@houseofdesign.de>", + "Nathan Gray <kolibrie@graystudios.org>", + "Nelo Onyiah <io1@sanger.ac.uk>", + "Nick Perez <nperez@cpan.org>", + "Olaf Alders <olaf@wundersolutions.com>", + "Olivier Mengué <dolmen@cpan.org>", + "Olof Johansson <olof@ethup.se>", + "Patrick Donelan <pat@patspam.com>", + "Paul Driver <frodwith@gmail.com>", + "Paul Jamieson Fenwick <pjf@perltraining.com.au>", + "Paweł Murias <pawelmurias@gmail.com>", + "Pedro Melo <melo@simplicidade.org>", + "Perlover <perlover@perlover.com>", + "Peter Shangov <pshangov@yahoo.com>", + "Philippe Bruhat (BooK) <book@cpan.org>", + "Phillip Smith <ps@phillipadsmith.com>", + "Piotr Roszatycki <piotr.roszatycki@gmail.com>", + "pktm <pktm@users.noreply.github.com>", + "Rafael Kitover <rkitover@cpan.org>", + "Ricardo Signes <rjbs@cpan.org>", + "Robert Boone <robo4288@gmail.com>", + "Robert Buels <rmb32@cornell.edu>", + "Robert 'phaylon' Sedlacek <rs@474.at>", + "Robin V <robinsp-gmail-com@nospam.com>", + "rodrigolive <rodrigolive@gmail.com>", + "Sam Vilain <sam.vilain@catalyst.net.nz>", + "Scott McWhirter <konobi@cpan.org>", + "shelling <navyblueshellingford@gmail.com>", + "Shlomi Fish <shlomif@iglu.org.il>", + "Stefan O'Rear <stefanor@cox.net>", + "Thomas Sibley <tsibley@cpan.org>", + "Todd Hepler <thepler@employees.org>", + "Tokuhiro Matsuno <tokuhirom@gp.ath.cx>", + "Tomas Doran <bobtfish@bobtfish.net>", + "Tuomas Jormola <tj@solitudo.net>", + "Upasana Shukla <me@upasana.me>", + "Wallace Reis <reis.wallace@gmail.com>", + "wickline <m-s-w-github@wickline.org>", + "Zachary Lome <zachary.lome@baml.com>", + "Zoffix Znet <cpan@zoffix.com>" + ] +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..d3e72a7 --- /dev/null +++ b/META.yml @@ -0,0 +1,1879 @@ +--- +abstract: 'A postmodern object system for Perl 5' +author: + - 'Stevan Little <stevan.little@iinteractive.com>' + - 'Dave Rolsky <autarch@urth.org>' + - 'Jesse Luehrs <doy@tozt.net>' + - 'Shawn M Moore <code@sartak.org>' + - "יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>" + - 'Karen Etheridge <ether@cpan.org>' + - 'Florian Ragwitz <rafl@debian.org>' + - 'Hans Dieter Pearcey <hdp@weftsoar.net>' + - 'Chris Prather <chris@prather.org>' + - 'Matt S Trout <mst@shadowcat.co.uk>' +build_requires: + CPAN::Meta::Check: '0.007' + CPAN::Meta::Requirements: '0' + ExtUtils::MakeMaker: '0' + File::Spec: '0' + Test::CleanNamespaces: '0.13' + Test::Fatal: '0.001' + Test::More: '0.88' + Test::Requires: '0.05' + Test::Warnings: '0.016' +configure_requires: + Dist::CheckConflicts: '0.02' + ExtUtils::CBuilder: '0.27' + ExtUtils::MakeMaker: '0' + File::Spec: '0' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 5.037, CPAN::Meta::Converter version 2.150001' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Moose +no_index: + directory: + - author + - benchmarks + - doc + - inc + namespace: + - Class::MOP::Mixin + - Moose::Meta::Method::Accessor::Native + - Moose::Meta::Mixin + package: + - Class::MOP::Class::Immutable::Trait + - Class::MOP::Deprecated + - Class::MOP::MiniTrait + - Class::MOP::Mixin + - Moose::Deprecated + - Moose::Meta::Attribute::Native::Trait + - Moose::Meta::Class::Immutable::Trait + - Moose::Meta::Method::Accessor::Native + - Moose::Meta::Object::Trait + - Moose::Util::TypeConstraints::Builtins +provides: + Class::MOP: + file: lib/Class/MOP.pm + version: '2.1405' + Class::MOP::Attribute: + file: lib/Class/MOP/Attribute.pm + version: '2.1405' + Class::MOP::Class: + file: lib/Class/MOP/Class.pm + version: '2.1405' + Class::MOP::Instance: + file: lib/Class/MOP/Instance.pm + version: '2.1405' + Class::MOP::Method: + file: lib/Class/MOP/Method.pm + version: '2.1405' + Class::MOP::Method::Accessor: + file: lib/Class/MOP/Method/Accessor.pm + version: '2.1405' + Class::MOP::Method::Constructor: + file: lib/Class/MOP/Method/Constructor.pm + version: '2.1405' + Class::MOP::Method::Generated: + file: lib/Class/MOP/Method/Generated.pm + version: '2.1405' + Class::MOP::Method::Inlined: + file: lib/Class/MOP/Method/Inlined.pm + version: '2.1405' + Class::MOP::Method::Meta: + file: lib/Class/MOP/Method/Meta.pm + version: '2.1405' + Class::MOP::Method::Wrapped: + file: lib/Class/MOP/Method/Wrapped.pm + version: '2.1405' + Class::MOP::Module: + file: lib/Class/MOP/Module.pm + version: '2.1405' + Class::MOP::Object: + file: lib/Class/MOP/Object.pm + version: '2.1405' + Class::MOP::Overload: + file: lib/Class/MOP/Overload.pm + version: '2.1405' + Class::MOP::Package: + file: lib/Class/MOP/Package.pm + version: '2.1405' + Moose: + file: lib/Moose.pm + version: '2.1405' + Moose::Cookbook: + file: lib/Moose/Cookbook.pod + version: '2.1405' + Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing: + file: lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod + version: '2.1405' + Moose::Cookbook::Basics::BinaryTree_AttributeFeatures: + file: lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod + version: '2.1405' + Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild: + file: lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod + version: '2.1405' + Moose::Cookbook::Basics::Company_Subtypes: + file: lib/Moose/Cookbook/Basics/Company_Subtypes.pod + version: '2.1405' + Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent: + file: lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod + version: '2.1405' + Moose::Cookbook::Basics::Document_AugmentAndInner: + file: lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod + version: '2.1405' + Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion: + file: lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod + version: '2.1405' + Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion: + file: lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod + version: '2.1405' + Moose::Cookbook::Basics::Immutable: + file: lib/Moose/Cookbook/Basics/Immutable.pod + version: '2.1405' + Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD: + file: lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod + version: '2.1405' + Moose::Cookbook::Basics::Point_AttributesAndSubclassing: + file: lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod + version: '2.1405' + Moose::Cookbook::Extending::Debugging_BaseClassRole: + file: lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod + version: '2.1405' + Moose::Cookbook::Extending::ExtensionOverview: + file: lib/Moose/Cookbook/Extending/ExtensionOverview.pod + version: '2.1405' + Moose::Cookbook::Extending::Mooseish_MooseSugar: + file: lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod + version: '2.1405' + Moose::Cookbook::Legacy::Debugging_BaseClassReplacement: + file: lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod + version: '2.1405' + Moose::Cookbook::Legacy::Labeled_AttributeMetaclass: + file: lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod + version: '2.1405' + Moose::Cookbook::Legacy::Table_ClassMetaclass: + file: lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod + version: '2.1405' + Moose::Cookbook::Meta::GlobRef_InstanceMetaclass: + file: lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod + version: '2.1405' + Moose::Cookbook::Meta::Labeled_AttributeTrait: + file: lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod + version: '2.1405' + Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass: + file: lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod + version: '2.1405' + Moose::Cookbook::Meta::Table_MetaclassTrait: + file: lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod + version: '2.1405' + Moose::Cookbook::Meta::WhyMeta: + file: lib/Moose/Cookbook/Meta/WhyMeta.pod + version: '2.1405' + Moose::Cookbook::Roles::ApplicationToInstance: + file: lib/Moose/Cookbook/Roles/ApplicationToInstance.pod + version: '2.1405' + Moose::Cookbook::Roles::Comparable_CodeReuse: + file: lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod + version: '2.1405' + Moose::Cookbook::Roles::Restartable_AdvancedComposition: + file: lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod + version: '2.1405' + Moose::Cookbook::Snack::Keywords: + file: lib/Moose/Cookbook/Snack/Keywords.pod + version: '2.1405' + Moose::Cookbook::Snack::Types: + file: lib/Moose/Cookbook/Snack/Types.pod + version: '2.1405' + Moose::Cookbook::Style: + file: lib/Moose/Cookbook/Style.pod + version: '2.1405' + Moose::Exception: + file: lib/Moose/Exception.pm + version: '2.1405' + Moose::Exception::AccessorMustReadWrite: + file: lib/Moose/Exception/AccessorMustReadWrite.pm + version: '2.1405' + Moose::Exception::AddParameterizableTypeTakesParameterizableType: + file: lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm + version: '2.1405' + Moose::Exception::AddRoleTakesAMooseMetaRoleInstance: + file: lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm + version: '2.1405' + Moose::Exception::AddRoleToARoleTakesAMooseMetaRole: + file: lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm + version: '2.1405' + Moose::Exception::ApplyTakesABlessedInstance: + file: lib/Moose/Exception/ApplyTakesABlessedInstance.pm + version: '2.1405' + Moose::Exception::AttachToClassNeedsAClassMOPClassInstanceOrASubclass: + file: lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm + version: '2.1405' + Moose::Exception::AttributeConflictInRoles: + file: lib/Moose/Exception/AttributeConflictInRoles.pm + version: '2.1405' + Moose::Exception::AttributeConflictInSummation: + file: lib/Moose/Exception/AttributeConflictInSummation.pm + version: '2.1405' + Moose::Exception::AttributeExtensionIsNotSupportedInRoles: + file: lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm + version: '2.1405' + Moose::Exception::AttributeIsRequired: + file: lib/Moose/Exception/AttributeIsRequired.pm + version: '2.1405' + Moose::Exception::AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass: + file: lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm + version: '2.1405' + Moose::Exception::AttributeNamesDoNotMatch: + file: lib/Moose/Exception/AttributeNamesDoNotMatch.pm + version: '2.1405' + Moose::Exception::AttributeValueIsNotAnObject: + file: lib/Moose/Exception/AttributeValueIsNotAnObject.pm + version: '2.1405' + Moose::Exception::AttributeValueIsNotDefined: + file: lib/Moose/Exception/AttributeValueIsNotDefined.pm + version: '2.1405' + Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef: + file: lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm + version: '2.1405' + Moose::Exception::BadOptionFormat: + file: lib/Moose/Exception/BadOptionFormat.pm + version: '2.1405' + Moose::Exception::BothBuilderAndDefaultAreNotAllowed: + file: lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm + version: '2.1405' + Moose::Exception::BuilderDoesNotExist: + file: lib/Moose/Exception/BuilderDoesNotExist.pm + version: '2.1405' + Moose::Exception::BuilderMethodNotSupportedForAttribute: + file: lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm + version: '2.1405' + Moose::Exception::BuilderMethodNotSupportedForInlineAttribute: + file: lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm + version: '2.1405' + Moose::Exception::BuilderMustBeAMethodName: + file: lib/Moose/Exception/BuilderMustBeAMethodName.pm + version: '2.1405' + Moose::Exception::CallingMethodOnAnImmutableInstance: + file: lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm + version: '2.1405' + Moose::Exception::CallingReadOnlyMethodOnAnImmutableInstance: + file: lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm + version: '2.1405' + Moose::Exception::CanExtendOnlyClasses: + file: lib/Moose/Exception/CanExtendOnlyClasses.pm + version: '2.1405' + Moose::Exception::CanOnlyConsumeRole: + file: lib/Moose/Exception/CanOnlyConsumeRole.pm + version: '2.1405' + Moose::Exception::CanOnlyWrapBlessedCode: + file: lib/Moose/Exception/CanOnlyWrapBlessedCode.pm + version: '2.1405' + Moose::Exception::CanReblessOnlyIntoASubclass: + file: lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm + version: '2.1405' + Moose::Exception::CanReblessOnlyIntoASuperclass: + file: lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm + version: '2.1405' + Moose::Exception::CannotAddAdditionalTypeCoercionsToUnion: + file: lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm + version: '2.1405' + Moose::Exception::CannotAddAsAnAttributeToARole: + file: lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm + version: '2.1405' + Moose::Exception::CannotApplyBaseClassRolesToRole: + file: lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm + version: '2.1405' + Moose::Exception::CannotAssignValueToReadOnlyAccessor: + file: lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm + version: '2.1405' + Moose::Exception::CannotAugmentIfLocalMethodPresent: + file: lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm + version: '2.1405' + Moose::Exception::CannotAugmentNoSuperMethod: + file: lib/Moose/Exception/CannotAugmentNoSuperMethod.pm + version: '2.1405' + Moose::Exception::CannotAutoDerefWithoutIsa: + file: lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm + version: '2.1405' + Moose::Exception::CannotAutoDereferenceTypeConstraint: + file: lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm + version: '2.1405' + Moose::Exception::CannotCalculateNativeType: + file: lib/Moose/Exception/CannotCalculateNativeType.pm + version: '2.1405' + Moose::Exception::CannotCallAnAbstractBaseMethod: + file: lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm + version: '2.1405' + Moose::Exception::CannotCallAnAbstractMethod: + file: lib/Moose/Exception/CannotCallAnAbstractMethod.pm + version: '2.1405' + Moose::Exception::CannotCoerceAWeakRef: + file: lib/Moose/Exception/CannotCoerceAWeakRef.pm + version: '2.1405' + Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion: + file: lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm + version: '2.1405' + Moose::Exception::CannotCreateHigherOrderTypeWithoutATypeParameter: + file: lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm + version: '2.1405' + Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresent: + file: lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm + version: '2.1405' + Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresentInClass: + file: lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm + version: '2.1405' + Moose::Exception::CannotDelegateLocalMethodIsPresent: + file: lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm + version: '2.1405' + Moose::Exception::CannotDelegateWithoutIsa: + file: lib/Moose/Exception/CannotDelegateWithoutIsa.pm + version: '2.1405' + Moose::Exception::CannotFindDelegateMetaclass: + file: lib/Moose/Exception/CannotFindDelegateMetaclass.pm + version: '2.1405' + Moose::Exception::CannotFindType: + file: lib/Moose/Exception/CannotFindType.pm + version: '2.1405' + Moose::Exception::CannotFindTypeGivenToMatchOnType: + file: lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm + version: '2.1405' + Moose::Exception::CannotFixMetaclassCompatibility: + file: lib/Moose/Exception/CannotFixMetaclassCompatibility.pm + version: '2.1405' + Moose::Exception::CannotGenerateInlineConstraint: + file: lib/Moose/Exception/CannotGenerateInlineConstraint.pm + version: '2.1405' + Moose::Exception::CannotInitializeMooseMetaRoleComposite: + file: lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm + version: '2.1405' + Moose::Exception::CannotInlineTypeConstraintCheck: + file: lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm + version: '2.1405' + Moose::Exception::CannotLocatePackageInINC: + file: lib/Moose/Exception/CannotLocatePackageInINC.pm + version: '2.1405' + Moose::Exception::CannotMakeMetaclassCompatible: + file: lib/Moose/Exception/CannotMakeMetaclassCompatible.pm + version: '2.1405' + Moose::Exception::CannotOverrideALocalMethod: + file: lib/Moose/Exception/CannotOverrideALocalMethod.pm + version: '2.1405' + Moose::Exception::CannotOverrideBodyOfMetaMethods: + file: lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm + version: '2.1405' + Moose::Exception::CannotOverrideLocalMethodIsPresent: + file: lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm + version: '2.1405' + Moose::Exception::CannotOverrideNoSuperMethod: + file: lib/Moose/Exception/CannotOverrideNoSuperMethod.pm + version: '2.1405' + Moose::Exception::CannotRegisterUnnamedTypeConstraint: + file: lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm + version: '2.1405' + Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously: + file: lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm + version: '2.1405' + Moose::Exception::CircularReferenceInAlso: + file: lib/Moose/Exception/CircularReferenceInAlso.pm + version: '2.1405' + Moose::Exception::ClassDoesNotHaveInitMeta: + file: lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm + version: '2.1405' + Moose::Exception::ClassDoesTheExcludedRole: + file: lib/Moose/Exception/ClassDoesTheExcludedRole.pm + version: '2.1405' + Moose::Exception::ClassNamesDoNotMatch: + file: lib/Moose/Exception/ClassNamesDoNotMatch.pm + version: '2.1405' + Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass: + file: lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm + version: '2.1405' + Moose::Exception::CodeBlockMustBeACodeRef: + file: lib/Moose/Exception/CodeBlockMustBeACodeRef.pm + version: '2.1405' + Moose::Exception::CoercingWithoutCoercions: + file: lib/Moose/Exception/CoercingWithoutCoercions.pm + version: '2.1405' + Moose::Exception::CoercionAlreadyExists: + file: lib/Moose/Exception/CoercionAlreadyExists.pm + version: '2.1405' + Moose::Exception::CoercionNeedsTypeConstraint: + file: lib/Moose/Exception/CoercionNeedsTypeConstraint.pm + version: '2.1405' + Moose::Exception::ConflictDetectedInCheckRoleExclusions: + file: lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm + version: '2.1405' + Moose::Exception::ConflictDetectedInCheckRoleExclusionsInToClass: + file: lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm + version: '2.1405' + Moose::Exception::ConstructClassInstanceTakesPackageName: + file: lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm + version: '2.1405' + Moose::Exception::CouldNotCreateMethod: + file: lib/Moose/Exception/CouldNotCreateMethod.pm + version: '2.1405' + Moose::Exception::CouldNotCreateWriter: + file: lib/Moose/Exception/CouldNotCreateWriter.pm + version: '2.1405' + Moose::Exception::CouldNotEvalConstructor: + file: lib/Moose/Exception/CouldNotEvalConstructor.pm + version: '2.1405' + Moose::Exception::CouldNotEvalDestructor: + file: lib/Moose/Exception/CouldNotEvalDestructor.pm + version: '2.1405' + Moose::Exception::CouldNotFindTypeConstraintToCoerceFrom: + file: lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm + version: '2.1405' + Moose::Exception::CouldNotGenerateInlineAttributeMethod: + file: lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm + version: '2.1405' + Moose::Exception::CouldNotLocateTypeConstraintForUnion: + file: lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm + version: '2.1405' + Moose::Exception::CouldNotParseType: + file: lib/Moose/Exception/CouldNotParseType.pm + version: '2.1405' + Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes: + file: lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm + version: '2.1405' + Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses: + file: lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm + version: '2.1405' + Moose::Exception::CreateMOPClassTakesHashRefOfMethods: + file: lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm + version: '2.1405' + Moose::Exception::CreateTakesArrayRefOfRoles: + file: lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm + version: '2.1405' + Moose::Exception::CreateTakesHashRefOfAttributes: + file: lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm + version: '2.1405' + Moose::Exception::CreateTakesHashRefOfMethods: + file: lib/Moose/Exception/CreateTakesHashRefOfMethods.pm + version: '2.1405' + Moose::Exception::DefaultToMatchOnTypeMustBeCodeRef: + file: lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm + version: '2.1405' + Moose::Exception::DelegationToAClassWhichIsNotLoaded: + file: lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm + version: '2.1405' + Moose::Exception::DelegationToARoleWhichIsNotLoaded: + file: lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm + version: '2.1405' + Moose::Exception::DelegationToATypeWhichIsNotAClass: + file: lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm + version: '2.1405' + Moose::Exception::DoesRequiresRoleName: + file: lib/Moose/Exception/DoesRequiresRoleName.pm + version: '2.1405' + Moose::Exception::EnumCalledWithAnArrayRefAndAdditionalArgs: + file: lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm + version: '2.1405' + Moose::Exception::EnumValuesMustBeString: + file: lib/Moose/Exception/EnumValuesMustBeString.pm + version: '2.1405' + Moose::Exception::ExtendsMissingArgs: + file: lib/Moose/Exception/ExtendsMissingArgs.pm + version: '2.1405' + Moose::Exception::HandlesMustBeAHashRef: + file: lib/Moose/Exception/HandlesMustBeAHashRef.pm + version: '2.1405' + Moose::Exception::IllegalInheritedOptions: + file: lib/Moose/Exception/IllegalInheritedOptions.pm + version: '2.1405' + Moose::Exception::IllegalMethodTypeToAddMethodModifier: + file: lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm + version: '2.1405' + Moose::Exception::IncompatibleMetaclassOfSuperclass: + file: lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm + version: '2.1405' + Moose::Exception::InitMetaRequiresClass: + file: lib/Moose/Exception/InitMetaRequiresClass.pm + version: '2.1405' + Moose::Exception::InitializeTakesUnBlessedPackageName: + file: lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm + version: '2.1405' + Moose::Exception::InstanceBlessedIntoWrongClass: + file: lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm + version: '2.1405' + Moose::Exception::InstanceMustBeABlessedReference: + file: lib/Moose/Exception/InstanceMustBeABlessedReference.pm + version: '2.1405' + Moose::Exception::InvalidArgPassedToMooseUtilMetaRole: + file: lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm + version: '2.1405' + Moose::Exception::InvalidArgumentToMethod: + file: lib/Moose/Exception/InvalidArgumentToMethod.pm + version: '2.1405' + Moose::Exception::InvalidArgumentsToTraitAliases: + file: lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm + version: '2.1405' + Moose::Exception::InvalidBaseTypeGivenToCreateParameterizedTypeConstraint: + file: lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm + version: '2.1405' + Moose::Exception::InvalidHandleValue: + file: lib/Moose/Exception/InvalidHandleValue.pm + version: '2.1405' + Moose::Exception::InvalidHasProvidedInARole: + file: lib/Moose/Exception/InvalidHasProvidedInARole.pm + version: '2.1405' + Moose::Exception::InvalidNameForType: + file: lib/Moose/Exception/InvalidNameForType.pm + version: '2.1405' + Moose::Exception::InvalidOverloadOperator: + file: lib/Moose/Exception/InvalidOverloadOperator.pm + version: '2.1405' + Moose::Exception::InvalidRoleApplication: + file: lib/Moose/Exception/InvalidRoleApplication.pm + version: '2.1405' + Moose::Exception::InvalidTypeConstraint: + file: lib/Moose/Exception/InvalidTypeConstraint.pm + version: '2.1405' + Moose::Exception::InvalidTypeGivenToCreateParameterizedTypeConstraint: + file: lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm + version: '2.1405' + Moose::Exception::InvalidValueForIs: + file: lib/Moose/Exception/InvalidValueForIs.pm + version: '2.1405' + Moose::Exception::IsaDoesNotDoTheRole: + file: lib/Moose/Exception/IsaDoesNotDoTheRole.pm + version: '2.1405' + Moose::Exception::IsaLacksDoesMethod: + file: lib/Moose/Exception/IsaLacksDoesMethod.pm + version: '2.1405' + Moose::Exception::LazyAttributeNeedsADefault: + file: lib/Moose/Exception/LazyAttributeNeedsADefault.pm + version: '2.1405' + Moose::Exception::Legacy: + file: lib/Moose/Exception/Legacy.pm + version: '2.1405' + Moose::Exception::MOPAttributeNewNeedsAttributeName: + file: lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm + version: '2.1405' + Moose::Exception::MatchActionMustBeACodeRef: + file: lib/Moose/Exception/MatchActionMustBeACodeRef.pm + version: '2.1405' + Moose::Exception::MessageParameterMustBeCodeRef: + file: lib/Moose/Exception/MessageParameterMustBeCodeRef.pm + version: '2.1405' + Moose::Exception::MetaclassIsAClassNotASubclassOfGivenMetaclass: + file: lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm + version: '2.1405' + Moose::Exception::MetaclassIsARoleNotASubclassOfGivenMetaclass: + file: lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm + version: '2.1405' + Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass: + file: lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm + version: '2.1405' + Moose::Exception::MetaclassMustBeASubclassOfMooseMetaClass: + file: lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm + version: '2.1405' + Moose::Exception::MetaclassMustBeASubclassOfMooseMetaRole: + file: lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm + version: '2.1405' + Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass: + file: lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm + version: '2.1405' + Moose::Exception::MetaclassNotLoaded: + file: lib/Moose/Exception/MetaclassNotLoaded.pm + version: '2.1405' + Moose::Exception::MetaclassTypeIncompatible: + file: lib/Moose/Exception/MetaclassTypeIncompatible.pm + version: '2.1405' + Moose::Exception::MethodExpectedAMetaclassObject: + file: lib/Moose/Exception/MethodExpectedAMetaclassObject.pm + version: '2.1405' + Moose::Exception::MethodExpectsFewerArgs: + file: lib/Moose/Exception/MethodExpectsFewerArgs.pm + version: '2.1405' + Moose::Exception::MethodExpectsMoreArgs: + file: lib/Moose/Exception/MethodExpectsMoreArgs.pm + version: '2.1405' + Moose::Exception::MethodModifierNeedsMethodName: + file: lib/Moose/Exception/MethodModifierNeedsMethodName.pm + version: '2.1405' + Moose::Exception::MethodNameConflictInRoles: + file: lib/Moose/Exception/MethodNameConflictInRoles.pm + version: '2.1405' + Moose::Exception::MethodNameNotFoundInInheritanceHierarchy: + file: lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm + version: '2.1405' + Moose::Exception::MethodNameNotGiven: + file: lib/Moose/Exception/MethodNameNotGiven.pm + version: '2.1405' + Moose::Exception::MustDefineAMethodName: + file: lib/Moose/Exception/MustDefineAMethodName.pm + version: '2.1405' + Moose::Exception::MustDefineAnAttributeName: + file: lib/Moose/Exception/MustDefineAnAttributeName.pm + version: '2.1405' + Moose::Exception::MustDefineAnOverloadOperator: + file: lib/Moose/Exception/MustDefineAnOverloadOperator.pm + version: '2.1405' + Moose::Exception::MustHaveAtLeastOneValueToEnumerate: + file: lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm + version: '2.1405' + Moose::Exception::MustPassAHashOfOptions: + file: lib/Moose/Exception/MustPassAHashOfOptions.pm + version: '2.1405' + Moose::Exception::MustPassAMooseMetaRoleInstanceOrSubclass: + file: lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm + version: '2.1405' + Moose::Exception::MustPassAPackageNameOrAnExistingClassMOPPackageInstance: + file: lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm + version: '2.1405' + Moose::Exception::MustPassEvenNumberOfArguments: + file: lib/Moose/Exception/MustPassEvenNumberOfArguments.pm + version: '2.1405' + Moose::Exception::MustPassEvenNumberOfAttributeOptions: + file: lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm + version: '2.1405' + Moose::Exception::MustProvideANameForTheAttribute: + file: lib/Moose/Exception/MustProvideANameForTheAttribute.pm + version: '2.1405' + Moose::Exception::MustSpecifyAtleastOneMethod: + file: lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm + version: '2.1405' + Moose::Exception::MustSpecifyAtleastOneRole: + file: lib/Moose/Exception/MustSpecifyAtleastOneRole.pm + version: '2.1405' + Moose::Exception::MustSpecifyAtleastOneRoleToApplicant: + file: lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm + version: '2.1405' + Moose::Exception::MustSupplyAClassMOPAttributeInstance: + file: lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm + version: '2.1405' + Moose::Exception::MustSupplyADelegateToMethod: + file: lib/Moose/Exception/MustSupplyADelegateToMethod.pm + version: '2.1405' + Moose::Exception::MustSupplyAMetaclass: + file: lib/Moose/Exception/MustSupplyAMetaclass.pm + version: '2.1405' + Moose::Exception::MustSupplyAMooseMetaAttributeInstance: + file: lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm + version: '2.1405' + Moose::Exception::MustSupplyAnAccessorTypeToConstructWith: + file: lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm + version: '2.1405' + Moose::Exception::MustSupplyAnAttributeToConstructWith: + file: lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm + version: '2.1405' + Moose::Exception::MustSupplyArrayRefAsCurriedArguments: + file: lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm + version: '2.1405' + Moose::Exception::MustSupplyPackageNameAndName: + file: lib/Moose/Exception/MustSupplyPackageNameAndName.pm + version: '2.1405' + Moose::Exception::NeedsTypeConstraintUnionForTypeCoercionUnion: + file: lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm + version: '2.1405' + Moose::Exception::NeitherAttributeNorAttributeNameIsGiven: + file: lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm + version: '2.1405' + Moose::Exception::NeitherClassNorClassNameIsGiven: + file: lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm + version: '2.1405' + Moose::Exception::NeitherRoleNorRoleNameIsGiven: + file: lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm + version: '2.1405' + Moose::Exception::NeitherTypeNorTypeNameIsGiven: + file: lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm + version: '2.1405' + Moose::Exception::NoAttributeFoundInSuperClass: + file: lib/Moose/Exception/NoAttributeFoundInSuperClass.pm + version: '2.1405' + Moose::Exception::NoBodyToInitializeInAnAbstractBaseClass: + file: lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm + version: '2.1405' + Moose::Exception::NoCasesMatched: + file: lib/Moose/Exception/NoCasesMatched.pm + version: '2.1405' + Moose::Exception::NoConstraintCheckForTypeConstraint: + file: lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm + version: '2.1405' + Moose::Exception::NoDestructorClassSpecified: + file: lib/Moose/Exception/NoDestructorClassSpecified.pm + version: '2.1405' + Moose::Exception::NoImmutableTraitSpecifiedForClass: + file: lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm + version: '2.1405' + Moose::Exception::NoParentGivenToSubtype: + file: lib/Moose/Exception/NoParentGivenToSubtype.pm + version: '2.1405' + Moose::Exception::OnlyInstancesCanBeCloned: + file: lib/Moose/Exception/OnlyInstancesCanBeCloned.pm + version: '2.1405' + Moose::Exception::OperatorIsRequired: + file: lib/Moose/Exception/OperatorIsRequired.pm + version: '2.1405' + Moose::Exception::OverloadConflictInSummation: + file: lib/Moose/Exception/OverloadConflictInSummation.pm + version: '2.1405' + Moose::Exception::OverloadRequiresAMetaClass: + file: lib/Moose/Exception/OverloadRequiresAMetaClass.pm + version: '2.1405' + Moose::Exception::OverloadRequiresAMetaMethod: + file: lib/Moose/Exception/OverloadRequiresAMetaMethod.pm + version: '2.1405' + Moose::Exception::OverloadRequiresAMetaOverload: + file: lib/Moose/Exception/OverloadRequiresAMetaOverload.pm + version: '2.1405' + Moose::Exception::OverloadRequiresAMethodNameOrCoderef: + file: lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm + version: '2.1405' + Moose::Exception::OverloadRequiresAnOperator: + file: lib/Moose/Exception/OverloadRequiresAnOperator.pm + version: '2.1405' + Moose::Exception::OverloadRequiresNamesForCoderef: + file: lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm + version: '2.1405' + Moose::Exception::OverrideConflictInComposition: + file: lib/Moose/Exception/OverrideConflictInComposition.pm + version: '2.1405' + Moose::Exception::OverrideConflictInSummation: + file: lib/Moose/Exception/OverrideConflictInSummation.pm + version: '2.1405' + Moose::Exception::PackageDoesNotUseMooseExporter: + file: lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm + version: '2.1405' + Moose::Exception::PackageNameAndNameParamsNotGivenToWrap: + file: lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm + version: '2.1405' + Moose::Exception::PackagesAndModulesAreNotCachable: + file: lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm + version: '2.1405' + Moose::Exception::ParameterIsNotSubtypeOfParent: + file: lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm + version: '2.1405' + Moose::Exception::ReferencesAreNotAllowedAsDefault: + file: lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm + version: '2.1405' + Moose::Exception::RequiredAttributeLacksInitialization: + file: lib/Moose/Exception/RequiredAttributeLacksInitialization.pm + version: '2.1405' + Moose::Exception::RequiredAttributeNeedsADefault: + file: lib/Moose/Exception/RequiredAttributeNeedsADefault.pm + version: '2.1405' + Moose::Exception::RequiredMethodsImportedByClass: + file: lib/Moose/Exception/RequiredMethodsImportedByClass.pm + version: '2.1405' + Moose::Exception::RequiredMethodsNotImplementedByClass: + file: lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm + version: '2.1405' + Moose::Exception::Role::Attribute: + file: lib/Moose/Exception/Role/Attribute.pm + version: '2.1405' + Moose::Exception::Role::AttributeName: + file: lib/Moose/Exception/Role/AttributeName.pm + version: '2.1405' + Moose::Exception::Role::Class: + file: lib/Moose/Exception/Role/Class.pm + version: '2.1405' + Moose::Exception::Role::EitherAttributeOrAttributeName: + file: lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm + version: '2.1405' + Moose::Exception::Role::Instance: + file: lib/Moose/Exception/Role/Instance.pm + version: '2.1405' + Moose::Exception::Role::InstanceClass: + file: lib/Moose/Exception/Role/InstanceClass.pm + version: '2.1405' + Moose::Exception::Role::InvalidAttributeOptions: + file: lib/Moose/Exception/Role/InvalidAttributeOptions.pm + version: '2.1405' + Moose::Exception::Role::Method: + file: lib/Moose/Exception/Role/Method.pm + version: '2.1405' + Moose::Exception::Role::ParamsHash: + file: lib/Moose/Exception/Role/ParamsHash.pm + version: '2.1405' + Moose::Exception::Role::Role: + file: lib/Moose/Exception/Role/Role.pm + version: '2.1405' + Moose::Exception::Role::RoleForCreate: + file: lib/Moose/Exception/Role/RoleForCreate.pm + version: '2.1405' + Moose::Exception::Role::RoleForCreateMOPClass: + file: lib/Moose/Exception/Role/RoleForCreateMOPClass.pm + version: '2.1405' + Moose::Exception::Role::TypeConstraint: + file: lib/Moose/Exception/Role/TypeConstraint.pm + version: '2.1405' + Moose::Exception::RoleDoesTheExcludedRole: + file: lib/Moose/Exception/RoleDoesTheExcludedRole.pm + version: '2.1405' + Moose::Exception::RoleExclusionConflict: + file: lib/Moose/Exception/RoleExclusionConflict.pm + version: '2.1405' + Moose::Exception::RoleNameRequired: + file: lib/Moose/Exception/RoleNameRequired.pm + version: '2.1405' + Moose::Exception::RoleNameRequiredForMooseMetaRole: + file: lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm + version: '2.1405' + Moose::Exception::RolesDoNotSupportAugment: + file: lib/Moose/Exception/RolesDoNotSupportAugment.pm + version: '2.1405' + Moose::Exception::RolesDoNotSupportExtends: + file: lib/Moose/Exception/RolesDoNotSupportExtends.pm + version: '2.1405' + Moose::Exception::RolesDoNotSupportInner: + file: lib/Moose/Exception/RolesDoNotSupportInner.pm + version: '2.1405' + Moose::Exception::RolesDoNotSupportRegexReferencesForMethodModifiers: + file: lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm + version: '2.1405' + Moose::Exception::RolesInCreateTakesAnArrayRef: + file: lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm + version: '2.1405' + Moose::Exception::RolesListMustBeInstancesOfMooseMetaRole: + file: lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm + version: '2.1405' + Moose::Exception::SingleParamsToNewMustBeHashRef: + file: lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm + version: '2.1405' + Moose::Exception::TriggerMustBeACodeRef: + file: lib/Moose/Exception/TriggerMustBeACodeRef.pm + version: '2.1405' + Moose::Exception::TypeConstraintCannotBeUsedForAParameterizableType: + file: lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm + version: '2.1405' + Moose::Exception::TypeConstraintIsAlreadyCreated: + file: lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm + version: '2.1405' + Moose::Exception::TypeParameterMustBeMooseMetaType: + file: lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm + version: '2.1405' + Moose::Exception::UnableToCanonicalizeHandles: + file: lib/Moose/Exception/UnableToCanonicalizeHandles.pm + version: '2.1405' + Moose::Exception::UnableToCanonicalizeNonRolePackage: + file: lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm + version: '2.1405' + Moose::Exception::UnableToRecognizeDelegateMetaclass: + file: lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm + version: '2.1405' + Moose::Exception::UndefinedHashKeysPassedToMethod: + file: lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm + version: '2.1405' + Moose::Exception::UnionCalledWithAnArrayRefAndAdditionalArgs: + file: lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm + version: '2.1405' + Moose::Exception::UnionTakesAtleastTwoTypeNames: + file: lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm + version: '2.1405' + Moose::Exception::ValidationFailedForInlineTypeConstraint: + file: lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm + version: '2.1405' + Moose::Exception::ValidationFailedForTypeConstraint: + file: lib/Moose/Exception/ValidationFailedForTypeConstraint.pm + version: '2.1405' + Moose::Exception::WrapTakesACodeRefToBless: + file: lib/Moose/Exception/WrapTakesACodeRefToBless.pm + version: '2.1405' + Moose::Exception::WrongTypeConstraintGiven: + file: lib/Moose/Exception/WrongTypeConstraintGiven.pm + version: '2.1405' + Moose::Exporter: + file: lib/Moose/Exporter.pm + version: '2.1405' + Moose::Intro: + file: lib/Moose/Intro.pod + version: '2.1405' + Moose::Manual: + file: lib/Moose/Manual.pod + version: '2.1405' + Moose::Manual::Attributes: + file: lib/Moose/Manual/Attributes.pod + version: '2.1405' + Moose::Manual::BestPractices: + file: lib/Moose/Manual/BestPractices.pod + version: '2.1405' + Moose::Manual::Classes: + file: lib/Moose/Manual/Classes.pod + version: '2.1405' + Moose::Manual::Concepts: + file: lib/Moose/Manual/Concepts.pod + version: '2.1405' + Moose::Manual::Construction: + file: lib/Moose/Manual/Construction.pod + version: '2.1405' + Moose::Manual::Contributing: + file: lib/Moose/Manual/Contributing.pod + version: '2.1405' + Moose::Manual::Delegation: + file: lib/Moose/Manual/Delegation.pod + version: '2.1405' + Moose::Manual::Delta: + file: lib/Moose/Manual/Delta.pod + version: '2.1405' + Moose::Manual::Exceptions: + file: lib/Moose/Manual/Exceptions.pod + version: '2.1405' + Moose::Manual::Exceptions::Manifest: + file: lib/Moose/Manual/Exceptions/Manifest.pod + version: '2.1405' + Moose::Manual::FAQ: + file: lib/Moose/Manual/FAQ.pod + version: '2.1405' + Moose::Manual::MOP: + file: lib/Moose/Manual/MOP.pod + version: '2.1405' + Moose::Manual::MethodModifiers: + file: lib/Moose/Manual/MethodModifiers.pod + version: '2.1405' + Moose::Manual::MooseX: + file: lib/Moose/Manual/MooseX.pod + version: '2.1405' + Moose::Manual::Resources: + file: lib/Moose/Manual/Resources.pod + version: '2.1405' + Moose::Manual::Roles: + file: lib/Moose/Manual/Roles.pod + version: '2.1405' + Moose::Manual::Support: + file: lib/Moose/Manual/Support.pod + version: '2.1405' + Moose::Manual::Types: + file: lib/Moose/Manual/Types.pod + version: '2.1405' + Moose::Manual::Unsweetened: + file: lib/Moose/Manual/Unsweetened.pod + version: '2.1405' + Moose::Meta::Attribute: + file: lib/Moose/Meta/Attribute.pm + version: '2.1405' + Moose::Meta::Attribute::Custom::Moose: + file: lib/Moose/Meta/Attribute.pm + version: '2.1405' + Moose::Meta::Attribute::Native: + file: lib/Moose/Meta/Attribute/Native.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::Array: + file: lib/Moose/Meta/Attribute/Native/Trait/Array.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::Bool: + file: lib/Moose/Meta/Attribute/Native/Trait/Bool.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::Code: + file: lib/Moose/Meta/Attribute/Native/Trait/Code.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::Counter: + file: lib/Moose/Meta/Attribute/Native/Trait/Counter.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::Hash: + file: lib/Moose/Meta/Attribute/Native/Trait/Hash.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::Number: + file: lib/Moose/Meta/Attribute/Native/Trait/Number.pm + version: '2.1405' + Moose::Meta::Attribute::Native::Trait::String: + file: lib/Moose/Meta/Attribute/Native/Trait/String.pm + version: '2.1405' + Moose::Meta::Class: + file: lib/Moose/Meta/Class.pm + version: '2.1405' + Moose::Meta::Instance: + file: lib/Moose/Meta/Instance.pm + version: '2.1405' + Moose::Meta::Method: + file: lib/Moose/Meta/Method.pm + version: '2.1405' + Moose::Meta::Method::Accessor: + file: lib/Moose/Meta/Method/Accessor.pm + version: '2.1405' + Moose::Meta::Method::Augmented: + file: lib/Moose/Meta/Method/Augmented.pm + version: '2.1405' + Moose::Meta::Method::Constructor: + file: lib/Moose/Meta/Method/Constructor.pm + version: '2.1405' + Moose::Meta::Method::Delegation: + file: lib/Moose/Meta/Method/Delegation.pm + version: '2.1405' + Moose::Meta::Method::Destructor: + file: lib/Moose/Meta/Method/Destructor.pm + version: '2.1405' + Moose::Meta::Method::Meta: + file: lib/Moose/Meta/Method/Meta.pm + version: '2.1405' + Moose::Meta::Method::Overridden: + file: lib/Moose/Meta/Method/Overridden.pm + version: '2.1405' + Moose::Meta::Role: + file: lib/Moose/Meta/Role.pm + version: '2.1405' + Moose::Meta::Role::Application: + file: lib/Moose/Meta/Role/Application.pm + version: '2.1405' + Moose::Meta::Role::Application::RoleSummation: + file: lib/Moose/Meta/Role/Application/RoleSummation.pm + version: '2.1405' + Moose::Meta::Role::Application::ToClass: + file: lib/Moose/Meta/Role/Application/ToClass.pm + version: '2.1405' + Moose::Meta::Role::Application::ToInstance: + file: lib/Moose/Meta/Role/Application/ToInstance.pm + version: '2.1405' + Moose::Meta::Role::Application::ToRole: + file: lib/Moose/Meta/Role/Application/ToRole.pm + version: '2.1405' + Moose::Meta::Role::Attribute: + file: lib/Moose/Meta/Role/Attribute.pm + version: '2.1405' + Moose::Meta::Role::Composite: + file: lib/Moose/Meta/Role/Composite.pm + version: '2.1405' + Moose::Meta::Role::Method: + file: lib/Moose/Meta/Role/Method.pm + version: '2.1405' + Moose::Meta::Role::Method::Conflicting: + file: lib/Moose/Meta/Role/Method/Conflicting.pm + version: '2.1405' + Moose::Meta::Role::Method::Required: + file: lib/Moose/Meta/Role/Method/Required.pm + version: '2.1405' + Moose::Meta::TypeCoercion: + file: lib/Moose/Meta/TypeCoercion.pm + version: '2.1405' + Moose::Meta::TypeCoercion::Union: + file: lib/Moose/Meta/TypeCoercion/Union.pm + version: '2.1405' + Moose::Meta::TypeConstraint: + file: lib/Moose/Meta/TypeConstraint.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Class: + file: lib/Moose/Meta/TypeConstraint/Class.pm + version: '2.1405' + Moose::Meta::TypeConstraint::DuckType: + file: lib/Moose/Meta/TypeConstraint/DuckType.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Enum: + file: lib/Moose/Meta/TypeConstraint/Enum.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Parameterizable: + file: lib/Moose/Meta/TypeConstraint/Parameterizable.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Parameterized: + file: lib/Moose/Meta/TypeConstraint/Parameterized.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Registry: + file: lib/Moose/Meta/TypeConstraint/Registry.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Role: + file: lib/Moose/Meta/TypeConstraint/Role.pm + version: '2.1405' + Moose::Meta::TypeConstraint::Union: + file: lib/Moose/Meta/TypeConstraint/Union.pm + version: '2.1405' + Moose::Object: + file: lib/Moose/Object.pm + version: '2.1405' + Moose::Role: + file: lib/Moose/Role.pm + version: '2.1405' + Moose::Spec::Role: + file: lib/Moose/Spec/Role.pod + version: '2.1405' + Moose::Unsweetened: + file: lib/Moose/Unsweetened.pod + version: '2.1405' + Moose::Util: + file: lib/Moose/Util.pm + version: '2.1405' + Moose::Util::MetaRole: + file: lib/Moose/Util/MetaRole.pm + version: '2.1405' + Moose::Util::TypeConstraints: + file: lib/Moose/Util/TypeConstraints.pm + version: '2.1405' + Test::Moose: + file: lib/Test/Moose.pm + version: '2.1405' + metaclass: + file: lib/metaclass.pm + version: '2.1405' + oose: + file: lib/oose.pm + version: '2.1405' +requires: + Carp: '1.22' + Class::Load: '0.09' + Class::Load::XS: '0.01' + Data::OptList: '0.107' + Devel::GlobalDestruction: '0' + Devel::OverloadInfo: '0.002' + Devel::StackTrace: '1.33' + Dist::CheckConflicts: '0.02' + Eval::Closure: '0.04' + List::MoreUtils: '0.28' + List::Util: '1.35' + MRO::Compat: '0.05' + Module::Runtime: '0.014' + Module::Runtime::Conflicts: '0.002' + Package::DeprecationManager: '0.11' + Package::Stash: '0.32' + Package::Stash::XS: '0.24' + Params::Util: '1.00' + Scalar::Util: '1.19' + Sub::Exporter: '0.980' + Sub::Identify: '0' + Sub::Name: '0.05' + Task::Weaken: '0' + Try::Tiny: '0.17' + parent: '0.223' + perl: v5.8.3 + strict: '1.03' + warnings: '1.03' +resources: + IRC: irc://irc.perl.org/#moose + MailingList: http://lists.perl.org/list/moose.html + bugtracker: https://rt.cpan.org/Dist/Display.html?Name=Moose + homepage: http://moose.perl.org/ + repository: git://github.com/moose/Moose.git +version: '2.1405' +x_Dist_Zilla: + perl: + version: '5.020002' + plugins: + - + class: Dist::Zilla::Plugin::EnsurePrereqsInstalled + name: EnsurePrereqsInstalled + version: '0.008' + - + class: Dist::Zilla::Plugin::Git::GatherDir + config: + Dist::Zilla::Plugin::GatherDir: + exclude_filename: + - Makefile.PL + - LICENSE + exclude_match: + - ^t/recipes/(?!basics_genome_overloadingsubtypesandcoercion) + follow_symlinks: '0' + include_dotfiles: '0' + prefix: '' + prune_directory: [] + root: . + Dist::Zilla::Plugin::Git::GatherDir: + include_untracked: '0' + name: Git::GatherDir + version: '2.034' + - + class: Dist::Zilla::Plugin::MetaYAML + name: MetaYAML + version: '5.037' + - + class: Dist::Zilla::Plugin::MetaJSON + name: MetaJSON + version: '5.037' + - + class: Dist::Zilla::Plugin::License + name: License + version: '5.037' + - + class: Dist::Zilla::Plugin::ExecDir + name: ExecDir + version: '5.037' + - + class: Dist::Zilla::Plugin::ShareDir + name: ShareDir + version: '5.037' + - + class: inc::MakeMaker + config: + Dist::Zilla::Role::TestRunner: + default_jobs: '9' + name: =inc::MakeMaker + version: ~ + - + class: Dist::Zilla::Plugin::Manifest + name: Manifest + version: '5.037' + - + class: Dist::Zilla::Plugin::MetaConfig + name: MetaConfig + version: '5.037' + - + class: inc::SimpleAuthority + name: =inc::SimpleAuthority + version: ~ + - + class: Dist::Zilla::Plugin::MetaResources + name: MetaResources + version: '5.037' + - + class: Dist::Zilla::Plugin::FileFinder::ByName + name: PodModules + version: '5.037' + - + class: Dist::Zilla::Plugin::FileFinder::Filter + name: ModulesSansPod + version: '5.037' + - + class: Dist::Zilla::Plugin::FileFinder::Filter + name: VersionedModules + version: '5.037' + - + class: inc::SimpleProvides + name: =inc::SimpleProvides + version: ~ + - + class: Dist::Zilla::Plugin::MetaProvides::Package + config: + Dist::Zilla::Plugin::MetaProvides::Package: + finder: + - ModulesSansPod + finder_objects: + - + class: Dist::Zilla::Plugin::FileFinder::Filter + name: ModulesSansPod + version: '5.037' + Dist::Zilla::Role::MetaProvider::Provider: + inherit_missing: '1' + inherit_version: '1' + meta_noindex: '1' + name: MetaProvides::Package + version: '2.003001' + - + class: Dist::Zilla::Plugin::MetaNoIndex + name: MetaNoIndex + version: '5.037' + - + class: Dist::Zilla::Plugin::Git::Contributors + config: + Dist::Zilla::Plugin::Git::Contributors: + include_authors: '0' + include_releaser: '1' + order_by: name + paths: [] + name: Git::Contributors + version: '0.011' + - + class: Dist::Zilla::Plugin::SurgicalPodWeaver + config: + Dist::Zilla::Plugin::PodWeaver: + finder: + - ':InstallModules' + - ':ExecFiles' + plugins: + - + class: Pod::Weaver::Plugin::EnsurePod5 + name: '@CorePrep/EnsurePod5' + version: '4.011' + - + class: Pod::Weaver::Plugin::H1Nester + name: '@CorePrep/H1Nester' + version: '4.011' + - + class: Pod::Weaver::Plugin::SingleEncoding + name: '@Default/SingleEncoding' + version: '4.011' + - + class: Pod::Weaver::Section::Name + name: '@Default/Name' + version: '4.011' + - + class: Pod::Weaver::Section::Version + name: '@Default/Version' + version: '4.011' + - + class: Pod::Weaver::Section::Region + name: '@Default/prelude' + version: '4.011' + - + class: Pod::Weaver::Section::Generic + name: SYNOPSIS + version: '4.011' + - + class: Pod::Weaver::Section::Generic + name: DESCRIPTION + version: '4.011' + - + class: Pod::Weaver::Section::Generic + name: OVERVIEW + version: '4.011' + - + class: Pod::Weaver::Section::Collect + name: ATTRIBUTES + version: '4.011' + - + class: Pod::Weaver::Section::Collect + name: METHODS + version: '4.011' + - + class: Pod::Weaver::Section::Collect + name: FUNCTIONS + version: '4.011' + - + class: Pod::Weaver::Section::Leftovers + name: '@Default/Leftovers' + version: '4.011' + - + class: Pod::Weaver::Section::Region + name: '@Default/postlude' + version: '4.011' + - + class: Pod::Weaver::Section::Authors + name: '@Default/Authors' + version: '4.011' + - + class: Pod::Weaver::Section::Legal + name: '@Default/Legal' + version: '4.011' + name: SurgicalPodWeaver + version: '0.0023' + - + class: Dist::Zilla::Plugin::RewriteVersion + name: RewriteVersion + version: '0.009' + - + class: Dist::Zilla::Plugin::Git::Describe + name: Git::Describe + version: '0.005' + - + class: inc::ExtractInlineTests + name: =inc::ExtractInlineTests + version: ~ + - + class: Dist::Zilla::Plugin::PromptIfStale + config: + Dist::Zilla::Plugin::PromptIfStale: + check_all_plugins: '1' + check_all_prereqs: '1' + modules: [] + phase: release + skip: [] + name: PromptIfStale + version: '0.044' + - + class: Dist::Zilla::Plugin::Test::EOL + config: + Dist::Zilla::Plugin::Test::EOL: + filename: xt/author/eol.t + finder: + - ':InstallModules' + - ':ExecFiles' + - ':TestFiles' + trailing_whitespace: '1' + name: Test::EOL + version: '0.18' + - + class: Dist::Zilla::Plugin::PodSyntaxTests + name: PodSyntaxTests + version: '5.037' + - + class: Dist::Zilla::Plugin::Test::NoTabs + config: + Dist::Zilla::Plugin::Test::NoTabs: + filename: xt/author/no-tabs.t + finder: + - ':InstallModules' + - ':ExecFiles' + - ':TestFiles' + name: Test::NoTabs + version: '0.15' + - + class: Dist::Zilla::Plugin::MetaTests + name: MetaTests + version: '5.037' + - + class: Dist::Zilla::Plugin::Test::Kwalitee + config: + Dist::Zilla::Plugin::Test::Kwalitee: + filename: xt/release/kwalitee.t + skiptest: + - use_strict + name: Test::Kwalitee + version: '2.11' + - + class: Dist::Zilla::Plugin::MojibakeTests + name: MojibakeTests + version: '0.7' + - + class: Dist::Zilla::Plugin::RunExtraTests + config: + Dist::Zilla::Role::TestRunner: + default_jobs: '9' + name: RunExtraTests + version: '0.027' + - + class: Dist::Zilla::Plugin::Test::ReportPrereqs + name: Test::ReportPrereqs + version: '0.021' + - + class: Dist::Zilla::Plugin::Test::CPAN::Changes + name: Test::CPAN::Changes + version: '0.009' + - + class: Dist::Zilla::Plugin::Test::Compile + config: + Dist::Zilla::Plugin::Test::Compile: + bail_out_on_fail: '1' + fail_on_warning: author + fake_home: '0' + filename: xt/release/00-compile.t + module_finder: + - ':InstallModules' + needs_display: '0' + phase: develop + script_finder: + - ':ExecFiles' + skips: + - ^Class::MOP::Attribute$ + - ^Class::MOP::Class$ + - ^Class::MOP::Method::Accessor$ + - ^Class::MOP::Method::Constructor$ + - ^Class::MOP::Method::Inlined$ + - ^Class::MOP::Method::Wrapped$ + - ^Class::MOP::Mixin::HasAttributes$ + - ^Class::MOP::Module$ + - ^Class::MOP::Package$ + - ^Moose::Meta::Attribute$ + - ^Moose::Meta::Attribute::Native$ + - ^Moose::Meta::Mixin::AttributeCore$ + - ^Moose::Meta::Role::Attribute$ + - ^Moose::Meta::TypeConstraint::Class$ + - ^Moose::Meta::TypeConstraint::DuckType$ + - ^Moose::Meta::TypeConstraint::Enum$ + - ^Moose::Meta::TypeConstraint::Parameterizable$ + - ^Moose::Meta::TypeConstraint::Parameterized$ + - ^Moose::Meta::TypeConstraint::Role$ + - ^Moose::Meta::TypeConstraint::Union$ + name: Test::Compile + version: '2.053' + - + class: inc::CheckReleaseType + name: =inc::CheckReleaseType + version: ~ + - + class: Dist::Zilla::Plugin::CheckVersionIncrement + name: CheckVersionIncrement + version: '0.121750' + - + class: Dist::Zilla::Plugin::CheckChangesHasContent + name: CheckChangesHasContent + version: '0.008' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: runtime + type: requires + name: Prereqs + version: '5.037' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: test + type: requires + name: TestRequires + version: '5.037' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: configure + type: requires + name: ConfigureRequires + version: '5.037' + - + class: Dist::Zilla::Plugin::Prereqs::AuthorDeps + name: Prereqs::AuthorDeps + version: '0.004' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: develop + type: requires + name: DevelopRequires + version: '5.037' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: runtime + type: suggests + name: RuntimeSuggests + version: '5.037' + - + class: Dist::Zilla::Plugin::Conflicts + name: Conflicts + version: '0.17' + - + class: Dist::Zilla::Plugin::Test::CheckBreaks + config: + Dist::Zilla::Plugin::Test::CheckBreaks: + conflicts_module: Moose::Conflicts + Dist::Zilla::Role::ModuleMetadata: + Module::Metadata: '1.000026' + version: '0.002' + name: Test::CheckBreaks + version: '0.012' + - + class: inc::CheckAuthorDeps + name: =inc::CheckAuthorDeps + version: ~ + - + class: inc::CheckDelta + name: =inc::CheckDelta + version: ~ + - + class: inc::GitUpToDate + name: =inc::GitUpToDate + version: ~ + - + class: Dist::Zilla::Plugin::Git::Remote::Check + name: Git::Remote::Check + version: 0.1.2 + - + class: Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch + config: + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: Git::CheckFor::CorrectBranch + version: '0.013' + - + class: Dist::Zilla::Plugin::Git::Check + config: + Dist::Zilla::Plugin::Git::Check: + untracked_files: die + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: [] + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: Git::Check + version: '2.034' + - + class: Dist::Zilla::Plugin::TestRelease + name: TestRelease + version: '5.037' + - + class: Dist::Zilla::Plugin::UploadToCPAN + name: UploadToCPAN + version: '5.037' + - + class: Dist::Zilla::Plugin::CopyFilesFromRelease + config: + Dist::Zilla::Plugin::CopyFilesFromRelease: + filename: + - Changes + - LICENSE + match: [] + name: CopyFilesFromRelease + version: '0.005' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: '%N-%v%t%n%n%c' + time_zone: local + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - Changes + - LICENSE + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: 'release snapshot' + version: '2.034' + - + class: Dist::Zilla::Plugin::Git::Tag + config: + Dist::Zilla::Plugin::Git::Tag: + branch: ~ + signed: 0 + tag: '2.1405' + tag_format: '%v' + tag_message: '%v%t' + time_zone: local + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: Git::Tag + version: '2.034' + - + class: Dist::Zilla::Plugin::BumpVersionAfterRelease + name: BumpVersionAfterRelease + version: '0.009' + - + class: Dist::Zilla::Plugin::NextRelease + name: NextRelease + version: '5.037' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: 'increment version after release' + time_zone: local + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - Changes + allow_dirty_match: + - (?^u:^lib/.*\.pm$) + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: 'increment version' + version: '2.034' + - + class: Dist::Zilla::Plugin::Git::Push + config: + Dist::Zilla::Plugin::Git::Push: + push_to: + - origin + remotes_must_exist: 1 + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: Git::Push + version: '2.034' + - + class: Dist::Zilla::Plugin::Run::AfterRelease + config: + Dist::Zilla::Plugin::Run::Role::Runner: + fatal_errors: 1 + quiet: 0 + run: + - 'git checkout master' + - 'git merge --ff-only stable/2.14' + - 'git push' + name: Run::AfterRelease + version: '0.038' + - + class: inc::GenerateDocs + name: =inc::GenerateDocs + version: ~ + - + class: inc::Clean + name: =inc::Clean + version: ~ + - + class: Dist::Zilla::Plugin::ConfirmRelease + name: ConfirmRelease + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':InstallModules' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':IncModules' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':TestFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ExecFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ShareFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':MainModule' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':AllFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':NoFiles' + version: '5.037' + zilla: + class: Dist::Zilla::Dist::Builder + config: + is_trial: '0' + version: '5.037' +x_authority: cpan:STEVAN +x_breaks: + Catalyst: '<= 5.90049999' + Config::MVP: '<= 2.200004' + Devel::REPL: '<= 1.003020' + Dist::Zilla::Plugin::Git: '<= 2.016' + Fey: '<= 0.36' + Fey::ORM: '<= 0.42' + File::ChangeNotify: '<= 0.15' + HTTP::Throwable: '<= 0.017' + KiokuDB: '<= 0.51' + Markdent: '<= 0.16' + Mason: '<= 2.18' + MooseX::ABC: '<= 0.05' + MooseX::Aliases: '<= 0.08' + MooseX::AlwaysCoerce: '<= 0.13' + MooseX::App: '<= 1.22' + MooseX::Attribute::Deflator: '<= 2.1.7' + MooseX::Attribute::Dependent: '<= 1.1.0' + MooseX::Attribute::Prototype: '<= 0.10' + MooseX::AttributeHelpers: '<= 0.22' + MooseX::AttributeIndexes: '<= 1.0.0' + MooseX::AttributeInflate: '<= 0.02' + MooseX::CascadeClearing: '<= 0.03' + MooseX::ClassAttribute: '<= 0.26' + MooseX::Constructor::AllErrors: '<= 0.021' + MooseX::Declare: '<= 0.35' + MooseX::FollowPBP: '<= 0.02' + MooseX::Getopt: '<= 0.56' + MooseX::InstanceTracking: '<= 0.04' + MooseX::LazyRequire: '<= 0.06' + MooseX::Meta::Attribute::Index: '<= 0.04' + MooseX::Meta::Attribute::Lvalue: '<= 0.05' + MooseX::Method::Signatures: '<= 0.44' + MooseX::MethodAttributes: '<= 0.22' + MooseX::NonMoose: '<= 0.24' + MooseX::Object::Pluggable: '<= 0.0011' + MooseX::POE: '<= 0.214' + MooseX::Params::Validate: '<= 0.05' + MooseX::PrivateSetters: '<= 0.03' + MooseX::Role::Cmd: '<= 0.06' + MooseX::Role::Parameterized: '<= 1.00' + MooseX::Role::WithOverloading: '<= 0.14' + MooseX::Runnable: '<= 0.03' + MooseX::Scaffold: '<= 0.05' + MooseX::SemiAffordanceAccessor: '<= 0.05' + MooseX::SetOnce: '<= 0.100473' + MooseX::Singleton: '<= 0.25' + MooseX::SlurpyConstructor: '<= 1.1' + MooseX::Storage: '<= 0.42' + MooseX::StrictConstructor: '<= 0.12' + MooseX::Traits: '<= 0.11' + MooseX::Types: '<= 0.19' + MooseX::Types::Parameterizable: '<= 0.05' + MooseX::Types::Set::Object: '<= 0.03' + MooseX::Types::Signal: '<= 1.101930' + MooseX::UndefTolerant: '<= 0.11' + PRANG: '<= 0.14' + Pod::Elemental: '<= 0.093280' + Pod::Weaver: '<= 3.101638' + Reaction: '<= 0.002003' + Test::Able: '<= 0.10' + Test::CleanNamespaces: '<= 0.03' + Test::Moose::More: '<= 0.022' + Test::TempDir: '<= 0.05' + Throwable: '<= 0.102080' + namespace::autoclean: '<= 0.08' +x_contributors: + - 'Aankhen <aankhen@gmail.com>' + - 'Adam J. Foxson <fhoxh@pobox.com>' + - 'Adam Kennedy <adamk@cpan.org>' + - 'Ævar Arnfjörð Bjarmason <avarab@gmail.com>' + - 'Anders Nor Berle <berle@cpan.org>' + - 'Ansgar Burchardt <ansgar@43-1.org>' + - 'Aran Clary Deltac <bluefeet@cpan.org>' + - 'Ash Berlin <ash@cpan.org>' + - 'A. Sinan Unur <nanis@cpan.org>' + - 'Brad Bowman <bsb@strategicdata.com.au>' + - 'Brendan Byrd <Perl@ResonatorSoft.org>' + - 'Brian Manning <elspicyjack@gmail.com>' + - 'Chad Granum <chad.granum@dreamhost.com>' + - 'Chankey Pathak <chankey007@gmail.com>' + - 'Chia-liang Kao <clkao@clkao.org>' + - 'Chip <chip@pobox.com>' + - 'Christian Hansen <chansen@cpan.org>' + - 'Christopher J. Madsen <perl@cjmweb.net>' + - 'Chris Weyl <cweyl@alumni.drew.edu>' + - 'chromatic <chromatic@wgz.org>' + - 'Cory Watson <github@onemogin.com>' + - 'Curtis Jewell <perl@csjewell.fastmail.us>' + - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>' + - 'Daisuke Maki (lestrrat) <daisuke@endeworks.jp>' + - 'Dan Dascalescu <ddascaNOSPAMlescu@gmail.com>' + - 'Dann <techmemo@gmail.com>' + - 'Dave Romano <dave.romano@ionzero.com>' + - 'David Leadbeater <dgl@dgl.cx>' + - 'David Steinbrunner <dsteinbrunner@MountainBook-Pro.local>' + - 'Dylan William Hardison <dylan@hardison.net>' + - 'Eric Wilhelm <ewilhelm@cpan.org>' + - 'Evan Carroll <evan@dealermade.com>' + - 'franck cuny <franck@lumberjaph.net>' + - 'Frew Schmidt <frioux@gmail.com>' + - 'Gerda Shank <gerda.shank@gmail.com>' + - 'gfx <gfuji@cpan.org>' + - 'Graham Knop <haarg@haarg.org>' + - 'gregor herrmann <gregoa@debian.org>' + - 'Guillermo Roditi <groditi@gmail.com>' + - 'hakim <hakim.cassimally@gmail.com>' + - 'Henry Van Styn <vanstyn@intellitree.com>' + - 'James Marca <james@activimetrics.com>' + - 'Jason May <jason.a.may@gmail.com>' + - 'Jay Allen <jay@endevver.com>' + - 'Jay Hannah <jay@jays.net>' + - 'Jay Kuri <jayk@jay-kuris-macbook.local>' + - 'Jeff Bisbee <jbisbee@biz.(none)>' + - 'Jesse Vincent <jesse@bestpractical.com>' + - 'Jess Robinson <cpan@desert-island.me.uk>' + - 'joel <joel@fysh.org>' + - 'John Douglas Porter <jdporter@cpan.org>' + - 'John Goulah <jgoulah@cpan.org>' + - 'John Napiorkowski <jjnapiork@cpan.org>' + - 'Jonathan Rockway <jon@jrock.us>' + - 'Justin DeVuyst <justin@devuyst.com>' + - 'Justin Hunter <justin.d.hunter@gmail.com>' + - 'Kent Fredric <kentnl@cpan.org>' + - 'Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>' + - 'Leon Brocard <acme@astray.com>' + - 'Marcel Grünauer <hanekomu@gmail.com>' + - 'Marc Mims <marc@questright.com>' + - 'Marcus Ramberg <marcus@nordaaker.com>' + - 'Mark Allen <mrallen1@yahoo.com>' + - 'Mark A. Stratman <stratman@gmail.com>' + - 'Mark Fowler <mark@twoshortplanks.com>' + - 'Mateu X Hunter <hunter@missoula.org>' + - 'Matthew Horsfall <wolfsage@gmail.com>' + - 'matthof <rmhofmann@gmail.com>' + - 'Matt Kraai <kraai@ftbfs.org>' + - 'Michael LaGrasta <michael@lagrasta.com>' + - 'Michael Rykov <mrykov@gmail.com>' + - 'Michael Schout <mschout@gkg.net>' + - 'Mike Whitaker <mike@altrion.org>' + - 'Moritz Onken <onken@houseofdesign.de>' + - 'Nathan Gray <kolibrie@graystudios.org>' + - 'Nelo Onyiah <io1@sanger.ac.uk>' + - 'Nick Perez <nperez@cpan.org>' + - 'Olaf Alders <olaf@wundersolutions.com>' + - 'Olivier Mengué <dolmen@cpan.org>' + - 'Olof Johansson <olof@ethup.se>' + - 'Patrick Donelan <pat@patspam.com>' + - 'Paul Driver <frodwith@gmail.com>' + - 'Paul Jamieson Fenwick <pjf@perltraining.com.au>' + - 'Paweł Murias <pawelmurias@gmail.com>' + - 'Pedro Melo <melo@simplicidade.org>' + - 'Perlover <perlover@perlover.com>' + - 'Peter Shangov <pshangov@yahoo.com>' + - 'Philippe Bruhat (BooK) <book@cpan.org>' + - 'Phillip Smith <ps@phillipadsmith.com>' + - 'Piotr Roszatycki <piotr.roszatycki@gmail.com>' + - 'pktm <pktm@users.noreply.github.com>' + - 'Rafael Kitover <rkitover@cpan.org>' + - 'Ricardo Signes <rjbs@cpan.org>' + - 'Robert Boone <robo4288@gmail.com>' + - 'Robert Buels <rmb32@cornell.edu>' + - "Robert 'phaylon' Sedlacek <rs@474.at>" + - 'Robin V <robinsp-gmail-com@nospam.com>' + - 'rodrigolive <rodrigolive@gmail.com>' + - 'Sam Vilain <sam.vilain@catalyst.net.nz>' + - 'Scott McWhirter <konobi@cpan.org>' + - 'shelling <navyblueshellingford@gmail.com>' + - 'Shlomi Fish <shlomif@iglu.org.il>' + - "Stefan O'Rear <stefanor@cox.net>" + - 'Thomas Sibley <tsibley@cpan.org>' + - 'Todd Hepler <thepler@employees.org>' + - 'Tokuhiro Matsuno <tokuhirom@gp.ath.cx>' + - 'Tomas Doran <bobtfish@bobtfish.net>' + - 'Tuomas Jormola <tj@solitudo.net>' + - 'Upasana Shukla <me@upasana.me>' + - 'Wallace Reis <reis.wallace@gmail.com>' + - 'wickline <m-s-w-github@wickline.org>' + - 'Zachary Lome <zachary.lome@baml.com>' + - 'Zoffix Znet <cpan@zoffix.com>' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..df1e1e9 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,246 @@ +# This Makefile.PL for Moose was generated by +# inc::MakeMaker <self> +# and Dist::Zilla::Plugin::MakeMaker::Awesome 0.34. +# Don't edit it but the dist.ini and plugins used to construct it. + +use strict; +use warnings; + +# Secondary compile testing via ExtUtils::CBuilder +sub can_xs { + # Do we have the configure_requires checker? + unless (eval 'require ExtUtils::CBuilder; ExtUtils::CBuilder->VERSION(0.27); 1') { + # They don't obey configure_requires, so it is + # someone old and delicate. Try to avoid hurting + # them by falling back to an older simpler test. + return can_cc(); + } + + return ExtUtils::CBuilder->new( quiet => 1 )->have_compiler; +} + +# can we locate a (the) C compiler +sub can_cc { + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# check if we can run some command +sub can_run { + my ($cmd) = @_; + + return $cmd if -x $cmd; + if (my $found_cmd = MM->maybe_command($cmd)) { + return $found_cmd; + } + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + next if $dir eq ''; + my $abs = File::Spec->catfile($dir, $cmd); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +die 'This distribution requires a working compiler' unless can_xs(); + +use ExtUtils::MakeMaker; +check_conflicts(); + +my %WriteMakefileArgs = ( + "ABSTRACT" => "A postmodern object system for Perl 5", + "AUTHOR" => "Stevan Little <stevan.little\@iinteractive.com>, Dave Rolsky <autarch\@urth.org>, Jesse Luehrs <doy\@tozt.net>, Shawn M Moore <code\@sartak.org>, \x{5d9}\x{5d5}\x{5d1}\x{5dc} \x{5e7}\x{5d5}\x{5d2}'\x{5de}\x{5df} (Yuval Kogman) <nothingmuch\@woobling.org>, Karen Etheridge <ether\@cpan.org>, Florian Ragwitz <rafl\@debian.org>, Hans Dieter Pearcey <hdp\@weftsoar.net>, Chris Prather <chris\@prather.org>, Matt S Trout <mst\@shadowcat.co.uk>", + "CONFIGURE_REQUIRES" => { + "Dist::CheckConflicts" => "0.02", + "ExtUtils::CBuilder" => "0.27", + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0 + }, + "DISTNAME" => "Moose", + "EXE_FILES" => [ + "bin/moose-outdated" + ], + "LICENSE" => "perl", + "NAME" => "Moose", + "OBJECT" => "xs/Attribute\$(OBJ_EXT) xs/AttributeCore\$(OBJ_EXT) xs/Class\$(OBJ_EXT) xs/Generated\$(OBJ_EXT) xs/HasAttributes\$(OBJ_EXT) xs/HasMethods\$(OBJ_EXT) xs/Inlined\$(OBJ_EXT) xs/Instance\$(OBJ_EXT) xs/Method\$(OBJ_EXT) xs/Moose\$(OBJ_EXT) xs/MOP\$(OBJ_EXT) xs/Package\$(OBJ_EXT) xs/ToInstance\$(OBJ_EXT) mop\$(OBJ_EXT)", + "PREREQ_PM" => { + "Carp" => "1.22", + "Class::Load" => "0.09", + "Class::Load::XS" => "0.01", + "Data::OptList" => "0.107", + "Devel::GlobalDestruction" => 0, + "Devel::OverloadInfo" => "0.002", + "Devel::StackTrace" => "1.33", + "Dist::CheckConflicts" => "0.02", + "Eval::Closure" => "0.04", + "List::MoreUtils" => "0.28", + "List::Util" => "1.35", + "MRO::Compat" => "0.05", + "Module::Runtime" => "0.014", + "Module::Runtime::Conflicts" => "0.002", + "Package::DeprecationManager" => "0.11", + "Package::Stash" => "0.32", + "Package::Stash::XS" => "0.24", + "Params::Util" => "1.00", + "Scalar::Util" => "1.19", + "Sub::Exporter" => "0.980", + "Sub::Identify" => 0, + "Sub::Name" => "0.05", + "Task::Weaken" => 0, + "Try::Tiny" => "0.17", + "parent" => "0.223", + "strict" => "1.03", + "warnings" => "1.03" + }, + "TEST_REQUIRES" => { + "CPAN::Meta::Check" => "0.007", + "CPAN::Meta::Requirements" => 0, + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "Test::CleanNamespaces" => "0.13", + "Test::Fatal" => "0.001", + "Test::More" => "0.88", + "Test::Requires" => "0.05", + "Test::Warnings" => "0.016" + }, + "VERSION" => "2.1405", + "XS" => { + "xs/Attribute.xs" => "xs/Attribute.c", + "xs/AttributeCore.xs" => "xs/AttributeCore.c", + "xs/Class.xs" => "xs/Class.c", + "xs/Generated.xs" => "xs/Generated.c", + "xs/HasAttributes.xs" => "xs/HasAttributes.c", + "xs/HasMethods.xs" => "xs/HasMethods.c", + "xs/Inlined.xs" => "xs/Inlined.c", + "xs/Instance.xs" => "xs/Instance.c", + "xs/MOP.xs" => "xs/MOP.c", + "xs/Method.xs" => "xs/Method.c", + "xs/Moose.xs" => "xs/Moose.c", + "xs/Package.xs" => "xs/Package.c", + "xs/ToInstance.xs" => "xs/ToInstance.c" + }, + "clean" => { + "FILES" => "xs/Attribute\$(OBJ_EXT) xs/AttributeCore\$(OBJ_EXT) xs/Class\$(OBJ_EXT) xs/Generated\$(OBJ_EXT) xs/HasAttributes\$(OBJ_EXT) xs/HasMethods\$(OBJ_EXT) xs/Inlined\$(OBJ_EXT) xs/Instance\$(OBJ_EXT) xs/Method\$(OBJ_EXT) xs/Moose\$(OBJ_EXT) xs/MOP\$(OBJ_EXT) xs/Package\$(OBJ_EXT) xs/ToInstance\$(OBJ_EXT) mop\$(OBJ_EXT)" + }, + "test" => { + "TESTS" => "t/*.t t/attributes/*.t t/basics/*.t t/bugs/*.t t/cmop/*.t t/compat/*.t t/examples/*.t t/exceptions/*.t t/immutable/*.t t/metaclasses/*.t t/moose_util/*.t t/native_traits/*.t t/recipes/*.t t/roles/*.t t/test_moose/*.t t/todo_tests/*.t t/type_constraints/*.t" + } +); + +my %FallbackPrereqs = ( + "CPAN::Meta::Check" => "0.007", + "CPAN::Meta::Requirements" => 0, + "Carp" => "1.22", + "Class::Load" => "0.09", + "Class::Load::XS" => "0.01", + "Data::OptList" => "0.107", + "Devel::GlobalDestruction" => 0, + "Devel::OverloadInfo" => "0.002", + "Devel::StackTrace" => "1.33", + "Dist::CheckConflicts" => "0.02", + "Eval::Closure" => "0.04", + "ExtUtils::CBuilder" => "0.27", + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "List::MoreUtils" => "0.28", + "List::Util" => "1.35", + "MRO::Compat" => "0.05", + "Module::Runtime" => "0.014", + "Module::Runtime::Conflicts" => "0.002", + "Package::DeprecationManager" => "0.11", + "Package::Stash" => "0.32", + "Package::Stash::XS" => "0.24", + "Params::Util" => "1.00", + "Scalar::Util" => "1.19", + "Sub::Exporter" => "0.980", + "Sub::Identify" => 0, + "Sub::Name" => "0.05", + "Task::Weaken" => 0, + "Test::CleanNamespaces" => "0.13", + "Test::Fatal" => "0.001", + "Test::More" => "0.88", + "Test::Requires" => "0.05", + "Test::Warnings" => "0.016", + "Try::Tiny" => "0.17", + "parent" => "0.223", + "strict" => "1.03", + "warnings" => "1.03" +); + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + delete $WriteMakefileArgs{TEST_REQUIRES}; + delete $WriteMakefileArgs{BUILD_REQUIRES}; + $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +$WriteMakefileArgs{CCFLAGS} = ( $Config::Config{ccflags} || '' ) . ' -I.'; + +WriteMakefile(%WriteMakefileArgs); + +{ +package MY; + +use Config; + +sub const_cccmd { + my $ret = shift->SUPER::const_cccmd(@_); + return q{} unless $ret; + + if ($Config{cc} =~ /^cl\b/i) { + warn 'you are using MSVC... we may not have gotten some options quite right.'; + $ret .= ' /Fo$@'; + } + else { + $ret .= ' -o $@'; + } + + return $ret; +} + +sub postamble { + return <<'EOF'; +$(OBJECT) : mop.h +EOF +} +} + +sub check_conflicts { + if ( eval { require 'lib/Moose/Conflicts.pm'; 1; } ) { + if ( eval { Moose::Conflicts->check_conflicts; 1 } ) { + return; + } + else { + my $err = $@; + $err =~ s/^/ /mg; + warn "***\n$err***\n"; + } + } + else { + print <<'EOF'; +*** + Your toolchain doesn't support configure_requires, so Dist::CheckConflicts + hasn't been installed yet. You should check for conflicting modules + manually using the 'moose-outdated' script that is installed with + this distribution once the installation finishes. +*** +EOF + } + + return if $ENV{AUTOMATED_TESTING} || $ENV{NONINTERACTIVE_TESTING}; + + # More or less copied from Module::Build + return if $ENV{PERL_MM_USE_DEFAULT}; + return unless -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); + + sleep 4; +} diff --git a/README.md b/README.md new file mode 100644 index 0000000..a15eecf --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +[](http://badge.fury.io/pl/Moose) +[](https://travis-ci.org/moose/Moose) +[](https://coveralls.io/r/moose/Moose?branch=master) + +Moose +===== + +Moose is a postmodern object system for Perl 5. + +Moose on CPAN: [https://metacpan.org/release/Moose] @@ -0,0 +1,488 @@ +# vim: set ft=markdown : + +## Uncontroversial Items + +These items are reasonably well thought out, and can go in any major release. + +### RT Tickets + +RT#59478/RT#63000 - 0+ overload causes NV conversion on == on perls before +5.14 - this causes comparisons to fail when the number can't fit in an NV +without precision loss. I'd like to fix this in a more general way (forcing +anyone else who might be using == on tc objects to do weird things isn't very +good), although it's hard to test to see what actually works. + +### Revise MetaRole API to reunify class/role metaroles: + + apply_metaroles( + for => $meta, + roles => { + attribute => [...], + class => [...], + role_attribute => [ ... ], + } + ); + +If the $meta is a class, we apply the roles to the class. If it's a role, we +hold onto them and apply them as part of applying the role to a class. + +To make this all work nicely, we'll probably want to track the original role +where a method was defined, just like we do with attributes currently. We'll +also need to store method modifiers with their original role, which may mean +adding some sort of Moose::Meta::Role::MethodModifier class. + +For each role-specific thing (methods, attributes, etc.) we should allow a +`role_attribute`, `role_method`, etc. key. The common case will be that the +metaroles are intended for the consuming class, but we should allow for +metaroles on the role's metaobjects as well. + +### Deprecate old-style Moose extensions + +Moose extensions that work by calling `Moose->init_meta(metaclass => +'Some::Custom::Metaclass', ...)` during their own `init_meta` should be +deprecated, so they can be removed later (this should fix the issues with +`init_meta` generation in Moose::Exporter, see RT51561) + +This needs to wait until the previous fix gets in, since it will hopefully +eliminate the need to write custom `init_meta` methods entirely. + +### Attributes in roles need to be able to participate in role composition + +Right now, this fails with no decent workaround: + + package R1; + use Moose::Role; + has foo => (is => 'ro'); + + package R2; + use Moose::Role; + with 'R1'; + requires 'foo'; + + package C; + use Moose; + with 'R2'; + +Role attributes really need to be able to participate in role-role combination. +This should also fix "with 'Role1', 'Role2'" being broken when Role1 implements +a method as an accessor and Role2 requires that method, but at least in that +case you can split it into two 'with' statements with minimal loss of +functionality. + +### Method modifiers in roles should silently add 'requires' for them + +This shouldn't be a functionality change, just a better error message (and +better introspectability). This shouldn't happen if the role already contains a +method by that name, so it'll depend on the previous fix going in (so "has foo +=> (is => 'ro'); around foo => sub { }" doesn't produce a 'requires' entry). + +### has +foo in roles + +There's no actual reason for this not to work, and it gets asked often enough +that we really should just do it at some point. + +### use Sub::Identify instead of doing our own thing with `get_code_info` + +No idea why we stopped using Sub::Identify in the past, but there's no reason +not to do this. We have a bug fix in our version (the `isGV_with_GP` thing), so +this should be submitted to Sub::Identify first. + +## Needs Thought + +These are things we think are good ideas, but they need more fleshing out. + +### Actual API for metaclass extensions + +Right now, the only way to bundle multiple metaclass traits is via +Moose::Exporter. This is unhelpful if you want to apply the extension to a +metaclass object rather than a class you're actually writing. We should come up +with an API for doing this. + +### MooseX::NonMoose in core + +I think all of the actual issues are solved at this point. The only issue is +the (necessary) implementation weirdness - it sets up multiple inheritance +between the non-Moose class and Moose::Object, and it installs a custom +constructor method at 'extends' time (although perhaps this could be solved by +moving some of the logic back into Moose::Object::new?). Other than that, it +handles everything transparently as far as I can tell. + +### Fix attribute and method metaclass compatibility + +So i got this wrong when rewriting it last year - right now, metaclass compat +checks the default attribute and method metaclasses, which is wrong. This means +that if a parent class does "use MooseX::FollowPBP", then attributes declared +in a subclass will get PBP-style accessors, which is quite surprising. + +On the other hand, sometimes metaclasses might need to be able to say "I'm +going to assume that all of my attributes at least inherit from this custom +class", so we might need to split it into "default specified by the user" and +"default specified by the metaclass" and only do compat checking on the second? +I'm not actually sure this is a valid use case though. + +Something that probably should be taken into account though is attributes and +methods that extend existing attributes or methods from a superclass should +inherit the metaclass of the existing one. Also not sure if this is correct, +but something to think about. + +### Rename a bunch of the public API methods + +Right now the public API is kind of a mess - we have things like `get_method` +vs `find_method_by_name` (you almost always want to use the latter), there +being no `has_method` equivalent that checks superclasses, `get_method_list` +being public but only returning method names, while `_get_local_methods` is +private (returning method objects), and yet neither of those looks at +superclasses, and basically none of this naming follows any kind of consistent +pattern. + +What we really need is a consistent and easy to remember API where the method +that people would think to use first is the method that they actually mean. +Something like renaming `find_method_by_name` to `find_method`, and `get_method` to +`find_local_method` or something along those lines. + +### Clean up metaclass constructors + +There's a _lot_ of different conventions in here. Some things to consider: + +* `new` vs `_new` +* allowing new( 'name', %args ) vs ( name => 'name', %args ) +* `Method->wrap` vs `Method->new` + +### Move method modifiers out to an external module + +Class::Method::Modifiers uses a different method for doing method modifiers, +which I'm not sure why we aren't using in Moose right now. Optionally using +Class::Method::Modifiers::Fast would be even better - it uses Data::Util to +implement XS method modifiers, which could help things a lot. + +### Move type constraints out to an external module + +There's nothing about our type constraint system that requires being tied to +Moose - it's conceptually an entirely separate system that Moose just happens +to use. Splitting it out into its own thing (that Moose could extend to add +things like role types) would make things conceptually a lot cleaner, and would +let people interested in just the type system have that. + +### Merge Class::MOP and Moose + +This is a long term goal, but would allow for a lot of things to be cleaned up. +There's a bunch of stuff that's duplicated, and other stuff that's not +implemented as well as it could be (Class::MOP::Method::Wrapped should be a +role, for instance). + +### Moose::Util::TypeConstraints vs Moose::Meta::Type{Coercion,Constraint} + +The Util module has _way_ too much functionality. It needs to be +refactored so it's a thin sugar layer on top of the meta API. As it +stands now, it does things like parse type names (and determine if +they're valid), manage the registry, and much more. + +### Anything with a \_(meta)?class method + +Every method that returns a class name needs to become a rw attribute +that can be set via the constructor. + +## Things to contemplate + +These are ideas we're not sure about. Prototypes are welcome, but we may never +merge the feature. + +### Does applying metaroles really need to reinitialize the metaclass? + +Seems like the logic that's actually necessary is already contained in +`rebless_instance`, and not reinitializing means that existing attributes and +methods won't be blown away when metaroles are applied. + +### Do we want to core namespace::autoclean behavior somehow? + +This would add Variable::Magic as a required XS dep (not a huge deal at the +moment, since Sub::Name is also a required XS dep, but it'd be nice for Moose +to be able to be pure perl again at some point in the future, and I'm not sure +what the relative chances of Sub::Name vs Variable::Magic making it into core +are). If we enabled it by default, this would also break things for people who +have introduced Moose into legacy-ish systems where roles are faked using +exporters (since those imported methods would be cleaned). + +If we decide we want this, we may want to core it as an option first ("use +Moose -clean" or so), and move to making it the default later. + +### Should using -excludes with a role add 'requires' for excluded methods? + +It seems to make sense, since otherwise you're violating the role's API +contract. + +### Moose "strict" mode + +use Moose 'strict'; This would allow us to have all sort of expensive tests +which can be turned off in prod. + +### Moose::Philosophy.pod + +To explain Moose from a very high level + +### moosedoc + +We certainly have enough meta-information to make pretty complete POD docs. + +## TODO test summary + +Note that some of these are fairly old, and may not be things we actually want +to do anymore. + +### `t/basics/basic_class_setup.t` + +Imports aren't automatically cleaned. Need to think about bringing +namespace::autoclean functionality into core. + +### `t/bugs/create_anon_recursion.t` + +Loading Moose::Meta::Class (or probably a lot of other metaclasses) before +loading Moose or Class::MOP causes issues (the bootstrapping gets confused). + +### `t/bugs/handles_foreign_class_bug.t` + +There should be a warning when delegated methods override 'new' (and possibly +others?). + +### `t/bugs/role_caller.t` + +Role methods should be cloned into classes on composition so that using +caller(0) in a role method uses the class's package, not the role's. + +### `t/cmop/metaclass_incompatibility.t` + +If a child class is created before a parent class, metaclass compatibility +checks won't run on the child when the parent is created, and so the child +could end up with an incompatible metaclass. + +### `t/cmop/modify_parent_method.t` + +Modifying parent class methods after a child class has already wrapped them +with a method modifier will cause the child class method to retain the original +method that it wrapped, not the new one it was replaced with. + +### `t/immutable/inline_close_over.t` + +Initializers and custom error classes still close over metaobjects. +Initializers do it because the initializer has to be passed in the attribute +metaobject as a parameter, and custom error classes can't be automatically +inlined. + +### `t/metaclasses/moose_exporter_trait_aliases.t` + +Renamed imports aren't cleaned on unimport. For instance: + + package Foo; + use Moose has => { -as => 'my_has' }; + no Moose; + # Foo still contains my_has + +### `t/metaclasses/reinitialize.t` + +Special method types can't have method metaroles applied. Applying a method +metarole to a class doesn't apply that role to things like constructors, +accessors, etc. + +### `t/roles/method_modifiers.t` + +Method modifiers in roles don't support the regex form of method selection. + +### `t/roles/role_compose_requires.t` + +Accessors for attributes defined in roles don't satisfy role method +requirements (this is detailed above - Attributes in roles need to be able to +participate in role composition). + +### `t/todo_tests/exception_reflects_failed_constraint.t` + +Type constraint failures should indicate which ancestor constraint failed - +subtype 'Foo', as 'Str', where { length < 5 } should mention Str when passed an +arrayref, but not when passed the string "ArrayRef". + +### `t/todo_tests/moose_and_threads.t` + +On 5.8, the type constraint name parser isn't thread safe. + +### `t/todo_tests/replacing_super_methods.t` + +Modifying parent class methods after a child class has already wrapped them +with a override will cause 'super' in the child class to call the original +parent class method, not the one it was overridden with. + +### `t/todo_tests/required_role_accessors.t` + +Role attribute accessors don't satisfy requires from roles they consume. + +### `t/todo_tests/role_insertion_order.t` + +Roles don't preserve attribute `insertion_order`. + +### `t/todo_tests/various_role_features.t` + +* Role attribute accessors don't satisfy requires from roles they consume. +* Role combination should produce a conflict when one role has an actual method + and the other role has an accessor. +* Role attribute accessors should not override methods in the class the role is + applied to. +* Role attribute accessors should be delegated when a class does + handles => 'Role'. +* Delegating to a role doesn't make $class->does('Role') true. +* Method modifier in a role doesn't create a method requirement. +* `Role->meta->has_method('attr_accessor')` is false. + +### `t/type_constraints/type_names.t` + +Type constraint object constructors don't validate the type name provided. + +### MooseX::Aliases in core + +Is there any reason why this would be bad? It would certainly make the +implementation a little faster (it can be inlined better). + +### MooseX::MethodAttributes in core + +discuss + +---- + +## Old todo + +Old todo stuff which may be totally out of date. + +### DDuncan's Str types + + subtype 'Str' + => as 'Value' + => where { Encode::is_utf8( $_[0] ) or $_[0] !~ m/[^0x00-0x7F]/x } + => optimize_as { defined($_[0]) && !ref($_[0]) }; + + subtype 'Blob' + => as 'Value' + => where { !Encode::is_utf8( $_[0] ) } + => optimize_as { defined($_[0]) && !ref($_[0]) }; + +### type unions + +Add support for doing it with Classes which do not have a type constraint yet +created + +### type intersections + +Mostly just for Roles +KENTNL is working on this + +### inherited slot specs + +'does' can be added to,.. but not changed (need type unions for this) + +### proxy attributes + +a proxied attribute is an attribute which looks like an attribute, talks like +an attribute, smells like an attribute,.. but if you look behind the +curtain,.. its over there.. in that other object + +(... probably be a custom metaclass) + +### local coerce + + [13:16] mst stevan: slight problem with coerce + [13:16] mst I only get to declare it once + [13:17] mst so if I'm trying to declare it cast-style per-source-class rather than per-target-class + [13:17] mst I am extremely screwed + [13:17] stevan yes + [13:17] stevan they are not class specific + [13:18] stevan they are attached to the type constraint itself + [13:18] * stevan ponders anon-coercion-metaobjects + [13:18] mst yes, that's fine + [13:19] mst but when I declare a class + [13:19] mst I want to be able to say "this class coerces to X type via <this>" + [13:19] stevan yeah something like that + [13:19] stevan oh,.. hmm + [13:20] stevan sort of like inflate/deflate? + [13:20] stevan around the accessors? + [13:25] * bluefeet has quit (Remote host closed the connection) + [13:27] mst no + [13:27] mst nothing like that + [13:27] mst like a cast + [13:31] mst stevan: $obj->foo($bar); where 'foo' expects a 'Foo' object + [13:31] mst stevan: is effectively <Foo>$bar, right? + [13:32] mst stevan: I want to be able to say in package Bar + [13:32] mst stevan: coerce_to 'Foo' via { ... }; + [13:32] mst etc. + [13:53] stevan hmm + +### add support for locally scoped TC + +This would borrow from MooseX::TypeLibrary to prefix the TC with the name +of the package. It would then be accesible from the outside as the fully +scoped name, but the local attributes would use it first. (this would need support +in the registry for this). + +### look into sugar extensions + +Use roles as sugar layer function providers (ala MooseX::AttributeHelpers). This +would allow custom metaclasses to provide roles to extend the sugar syntax with. + +(NOTE: Talk to phaylon a bit more on this) + +### allow a switch of some kind to optionally turn TC checking off at runtime + +The type checks can get expensive and some people have suggested that allowing +the checks to be turned off would be helpful for deploying into performance +intensive systems. Perhaps this can actually be done as an option to `make_immutable`? + +### misc. minor bits + +* make the errors for TCs use `->message` +* look into localizing the messages too +* make ANON TCs be lazy, so they can possibly be subsituted for the real thing later +* make ANON TCs more introspectable +* add this ... + + subtype 'Username', + from 'Str', + where { (/[a-z][a-z0-9]+/i or fail('Invalid character(s)')) + and (length($_) >= 5 or fail('Too short (less than 5 chars)')) + } + on_fail { MyException->throw(value => $_[0], message => $_[1]) }; + +fail() will just return false unless the call is made via `$tc->check_or_fail($value);` + +* and then something like this: + + subtype Foo => as Bar => where { ... } => scoped => -global; + subtype Foo => as Bar => where { ... } => scoped => -local; + + # or + + subtype Foo => as Bar => where { ... } => in __PACKAGE__ ; + + # or (not sure if it would be possible) + + my $Foo = subtype Bar => where { ... }; + +### Deep coercion? + + [17:10] <autarch> stevan: it should do it if I pass coerce => 1 as part of the attribute definition + [17:12] <stevan> autarch: what I am not 100% sure of is how to tell it to deep coerce and when to not + [17:13] <stevan> cause a basic coerce is from A to B + [17:13] <autarch> hmm + [17:13] <stevan> which is valid for collection types too + [17:13] <stevan> deep coercion is what you are asking for + [17:13] <autarch> yeah + [17:13] <stevan> so perhaps we add deep_coerce => 1 + [17:13] <stevan> which will do it + [17:13] <autarch> that's fine for me + [17:13] <stevan> k + +`coerce_deeply => 1 # reads better` + +### Moose::Meta::TypeConstraint::Parameter{izable,ized} + +The relationship between these two classes is very odd. In particular, +this line in Parameterized is insane: + + foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) { + +Why does it need to loop through all parameterizable types? Shouldn't +it know which parameterizable type it "came from"? diff --git a/author/docGenerator.pl b/author/docGenerator.pl new file mode 100644 index 0000000..6e3eef0 --- /dev/null +++ b/author/docGenerator.pl @@ -0,0 +1,279 @@ +use blib; +use Moose; +use Class::Load 0.07 qw(load_class); + +my $text = generate_docs(); +print $text; + +sub generate_docs { + my $dir; + my $path = 'lib/Moose/Exception/'; + my $pod_file; + + opendir( $dir, $path) or die $!; + + my $version = $ARGV[0]; + + my $number = 0; + my $text = ''; + + my $exceptions_to_msg_hashref = get_exceptions_to_messages(); + + while( my $file = readdir($dir) ) + { + my %exceptions = %$exceptions_to_msg_hashref; + + my ($exception, $description, $attributes_text, $superclasses, $consumed_roles, $exception_messages); + my (@attributes, @roles, @super_classes, @roles_names, @super_class_names); + if( !(-d 'lib/Moose/Exception/'.$file) ) + { + $file =~ s/\.pm//i; + + $exception = "Moose::Exception::".$file; + + load_class( $exception ); + my $metaclass = Class::MOP::class_of( $exception ) + or die "No metaclass for $exception"; + + my @super_classes = sort { $a->name cmp $b->name } $metaclass->superclasses; + my @roles = sort { $a->name cmp $b->name } $metaclass->calculate_all_roles; + my @attributes = sort { $a->name cmp $b->name } $metaclass->get_all_attributes; + + my $file_handle; + + @roles_names = map { + my $name = $_->name; + if( $name =~ /\|/ ) { + undef; + } else { + $name; + } + } @roles; + + $superclasses = place_commas_and_and( @super_classes ); + $consumed_roles = place_commas_and_and( @roles_names ); + + foreach my $attribute ( @attributes ) + { + my $name = $attribute->name; + my $traits; + + if( $attribute->has_applied_traits ) { + my @traits_array = @{$attribute->applied_traits}; + + $traits = "has traits of "; + my $traits_str = place_commas_and_and( @traits_array ); + $traits .= $traits_str; + } + + my ( $tc, $type_constraint ) = ( $attribute->type_constraint->name, "isa " ); + if( $tc =~ /::/ && !(defined $traits) ) { + $type_constraint .= "L<".$tc.">"; + } else { + $type_constraint .= $tc; + } + my $read_or_write = ( $attribute->has_writer ? 'is read-write' : 'is read-only' ); + my $required = ( $attribute->is_required ? 'is required' : 'is optional' ); + my $predicate = ( $attribute->has_predicate ? 'has a predicate C<'.$attribute->predicate.'>': undef ); + + my $default; + if( $attribute->has_default ) { + if( $tc eq "Str" ) { + $default = 'has a default value "'.$attribute->default.'"'; + } + else { + $default = 'has a default value '.$attribute->default; + } + } + + my $handles_text; + if( $attribute->has_handles ) { + my %handles = %{$attribute->handles}; + my @keys = sort keys( %handles ); + my $first_element_inserted = 1; + foreach my $key ( @keys ) { + next + if( $key =~ /^_/ ); + my $str_text = sprintf("\n %-25s=> %s", $key, $handles{$key}); + if( $first_element_inserted == 1 ) { + $handles_text = "This attribute has handles as follows:"; + $first_element_inserted = 0; + } + $handles_text .= $str_text; + } + } + + $exception_messages = "=back\n\n=head4 Sample Error Message"; + + my $msg_or_msg_ref = $exceptions{$file}; + if( ref $msg_or_msg_ref eq "ARRAY" ) { + $exception_messages .= "s:\n\n"; + my @array = @$msg_or_msg_ref; + foreach( @array ) { + $exception_messages .= " $_"; + } + } else { + $exception_messages .= ":\n\n"; + if( $exceptions{$file} ) { + $exception_messages .= " ".$exceptions{$file}; + } + } + + $exception_messages .= "\n"; + + $attributes_text .= "=item B<< \$exception->$name >>\n\n"; + if( $attribute->has_documentation ) { + $attributes_text .= $attribute->documentation."\n\n"; + } else { + $attributes_text .= "This attribute $read_or_write, $type_constraint". + ( defined $predicate ? ", $predicate" : '' ). + ( defined $default ? ", $default" : ''). + " and $required.". + ( defined $handles_text && ( $handles_text ne "This attribute has handles as follows:\n" ) ? "\n\n$handles_text" : '' )."\n\n"; + } + } + my $role_verb = "consume".( $#roles == 0 ? 's role' : ' roles' ); + + $text .= "=head1 Moose::Exception::$file\n\nThis class is a subclass of $superclasses". +( defined $consumed_roles ? " and $role_verb $consumed_roles.": '.' ). +"\n\n=over 4\n\n=back\n\n=head2 ATTRIBUTES\n\n=over 4\n\n". +( defined $attributes_text ? "$attributes_text\n\n" : '' ); + + $text = fix_line_length( $text ); + $text .= $exception_messages; + $number++; + $text =~ s/\s+$//; + $text .= "\n\n"; + } + } + + return $text; +} + +sub fix_line_length { + my $doc = shift; + + my @tokens = split /\n/, $doc; + + my $str; + foreach( @tokens ) { + my $string = shorten_to_eighty($_); + $str .= ($string."\n"); + } + return $str."\n"; +} + +sub shorten_to_eighty { + my ($str) = @_; + if( length $str > 80 && length $str != 81 ) { + my $s1 = substr($str, 0, 80); + my $s2 = substr($str, 80); + my $substr1 = substr($s1, length($s1) - 1 ); + my $substr2 = substr($s2, 0, 1); + $s1 =~ s/[\s]+$//g; + $s2 =~ s/[\s]+$//g; + if( ( $substr1 =~ /[\(\)\[\w:,'"<>\]\$]/ ) && ( $substr2 =~ /[\$'"\(\)\[<>\w:,\]]/ ) ) { + if( $s1 =~ s/\s([\(\)\[<:\w+>,"'\]\$]+)$// ) { + $s1 =~ s/[\s]+$//g; + $s2 = $1.$s2; + $s2 =~ s/[\s]+$//g; + my $s3 = shorten_to_eighty( $s2 ); + $s3 =~ s/[\s]+$//g; + $s2 =~ s/[\s]+$//g; + if( $s2 ne $s3 ) { + return "$s1\n$s3"; + } else { + return "$s1\n$s2"; + } + } + } + return "$s1\n$s2"; + } + else + { + return $str; + } +} + +sub place_commas_and_and { + my @array = @_; + my ($str, $last_undef); + + for( my $i = 0; $i <= $#array; $i++ ) { + my $element = $array[$i]; + if( !(defined $element ) ) { + $last_undef = 1; + next; + } + if ( $i == 0 || ( $last_undef && $i == 1 ) ) { + $str .= "L<$element>"; + } elsif( $i == $#array ) { + $str .= " and L<$element>"; + } else { + $str .= ", L<$element>"; + } + $last_undef = 0; + } + return $str; +} + +sub get_exceptions_to_messages { + my $test_dir; + my $test_path = 't/exceptions/'; + + my %hash; + + opendir( $test_dir, $test_path ) or die $!; + + my $file; + while( $file = readdir( $test_dir ) ) { + my $file_handle; + + open( $file_handle, "t/exceptions/$file" ) or die $!; + my ($message, $exception); + while( <$file_handle> ) { + if( /like\($/ ) { + my $exception_var = <$file_handle>; + if( $exception_var =~ /\$exception,$/ ) { + $message = <$file_handle>; + if( $message =~ q/\$\w+/ || ( $message =~ /\\\(\w+\\\)/) ) { + my $garbage = <$file_handle>; + $message = <$file_handle>; + $message =~ s/^\s+#//; + } + $message =~ s!^\s*qr(/|\!)(\^)?(\\Q)?!!; + $message =~ s!(/|\!),$!!; + } + } elsif( /isa_ok\($/ ) { + my $exception_var = <$file_handle>; + if( $exception_var =~ /\$exception(->error)?,$/ ) { + $exception = <$file_handle>; + if( $exception =~ /Moose::Exception::(\w+)/ ) { + $exception = $1; + } + } + } + + if( ( defined $exception ) && ( defined $message ) ) { + if( exists $hash{$exception} && + ( ref $hash{$exception} eq "ARRAY" ) ) { + my @array = @{$hash{$exception}}; + push @array, $message; + $hash{$exception} = \@array; + } elsif( exists $hash{$exception} && + ( $hash{$exception} ne $message ) ) { + my $msg = $hash{$exception}; + my $array_ref = [ $msg, $message ]; + $hash{$exception} = $array_ref; + } else { + $hash{$exception} = $message; + } + $exception = undef; + $message = undef; + } + } + close $file_handle; + } + + return \%hash; +} diff --git a/author/extract-inline-tests b/author/extract-inline-tests new file mode 100755 index 0000000..aa90787 --- /dev/null +++ b/author/extract-inline-tests @@ -0,0 +1,47 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use File::Find::Rule; +use Getopt::Long; +use Test::Inline; + +use lib 'inc'; +use MyInline; + +my $quiet; +GetOptions( 'quiet' => \$quiet ); + +my $inline = Test::Inline->new( + verbose => !$quiet, + ExtractHandler => 'My::Extract', + ContentHandler => 'My::Content', + OutputHandler => 'My::Output', +); + +for my $pod ( + File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) { + $inline->add($pod); +} + +$inline->save; + +{ + + package My::Output; + + use Path::Tiny; + + sub write { + my $class = shift; + my $name = shift; + my $content = shift; + + $name =~ s/^moose_cookbook_//; + + path( "t/recipes/$name" )->spew( $content ); + + return 1; + } +} diff --git a/author/find-dupe-test-numbers b/author/find-dupe-test-numbers new file mode 100755 index 0000000..ce975a0 --- /dev/null +++ b/author/find-dupe-test-numbers @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use File::Basename qw( basename ); + +for my $subdir ( glob 't/*' ) { + my %files; + + for my $file ( map { basename($_) } glob "$subdir/*.t" ) { + my ($number) = $file =~ /^(\d+)/; + next unless defined $number; + + push @{ $files{$number} }, $file; + } + + for my $number ( grep { @{ $files{$_} } > 1 } keys %files ) { + print $subdir, "\n"; + print ' - ', $_, "\n" for @{ $files{$number} }; + print "\n"; + } +} diff --git a/benchmarks/caf_vs_moose.pl b/benchmarks/caf_vs_moose.pl new file mode 100644 index 0000000..ef6ef28 --- /dev/null +++ b/benchmarks/caf_vs_moose.pl @@ -0,0 +1,85 @@ +#!perl + +### MODULES + +{ + package PlainMoose; + use Moose; + has foo => (is => 'rw'); +} +{ + package MooseImmutable; + use Moose; + has foo => (is => 'rw'); + __PACKAGE__->meta->make_immutable(); +} +{ + package MooseImmutable::NoConstructor; + use Moose; + has foo => (is => 'rw'); + __PACKAGE__->meta->make_immutable(inline_constructor => 0); +} +{ + package ClassAccessorFast; + use warnings; + use strict; + use base 'Class::Accessor::Fast'; + __PACKAGE__->mk_accessors(qw(foo)); +} + +use Benchmark qw(cmpthese); +use Benchmark ':hireswallclock'; + +my $moose = PlainMoose->new; +my $moose_immut = MooseImmutable->new; +my $moose_immut_no_const = MooseImmutable::NoConstructor->new; +my $caf = ClassAccessorFast->new; + +my $acc_rounds = 100_000; +my $ins_rounds = 100_000; + +print "\nSETTING\n"; +cmpthese($acc_rounds, { + Moose => sub { $moose->foo(23) }, + MooseImmutable => sub { $moose_immut->foo(23) }, + MooseImmutableNoConstructor => sub { $moose_immut_no_const->foo(23) }, + ClassAccessorFast => sub { $caf->foo(23) }, +}, 'noc'); + +print "\nGETTING\n"; +cmpthese($acc_rounds, { + Moose => sub { $moose->foo }, + MooseImmutable => sub { $moose_immut->foo }, + MooseImmutableNoConstructor => sub { $moose_immut_no_const->foo }, + ClassAccessorFast => sub { $caf->foo }, +}, 'noc'); + +my (@moose, @moose_immut, @moose_immut_no_const, @caf_stall); +print "\nCREATION\n"; +cmpthese($ins_rounds, { + Moose => sub { push @moose, PlainMoose->new(foo => 23) }, + MooseImmutable => sub { push @moose_immut, MooseImmutable->new(foo => 23) }, + MooseImmutableNoConstructor => sub { push @moose_immut_no_const, MooseImmutable::NoConstructor->new(foo => 23) }, + ClassAccessorFast => sub { push @caf_stall, ClassAccessorFast->new({foo => 23}) }, +}, 'noc'); + +my ( $moose_idx, $moose_immut_idx, $moose_immut_no_const_idx, $caf_idx ) = ( 0, 0, 0, 0 ); +print "\nDESTRUCTION\n"; +cmpthese($ins_rounds, { + Moose => sub { + $moose[$moose_idx] = undef; + $moose_idx++; + }, + MooseImmutable => sub { + $moose_immut[$moose_immut_idx] = undef; + $moose_immut_idx++; + }, + MooseImmutableNoConstructor => sub { + $moose_immut_no_const[$moose_immut_no_const_idx] = undef; + $moose_immut_no_const_idx++; + }, + ClassAccessorFast => sub { + $caf_stall[$caf_idx] = undef; + $caf_idx++; + }, +}, 'noc'); diff --git a/benchmarks/cmop/all.yml b/benchmarks/cmop/all.yml new file mode 100644 index 0000000..f0d5758 --- /dev/null +++ b/benchmarks/cmop/all.yml @@ -0,0 +1,29 @@ +--- +- name: Point classes + classes: + - 'MOP::Point' + - 'MOP::Point3D' + - 'MOP::Immutable::Point' + - 'MOP::Immutable::Point3D' + - 'MOP::Installed::Point' + - 'MOP::Installed::Point3D' + - 'Plain::Point' + - 'Plain::Point3D' + benchmarks: + - class: 'Bench::Construct' + name: object construction + args: + y: 137 + - class: 'Bench::Accessor' + name: accessor get + construct: + x: 4 + y: 6 + accessor: x + - class: 'Bench::Accessor' + name: accessor set + construct: + x: 4 + y: 6 + accessor: x + accessor_args: [ 5 ] diff --git a/benchmarks/cmop/foo.pl b/benchmarks/cmop/foo.pl new file mode 100755 index 0000000..e99365b --- /dev/null +++ b/benchmarks/cmop/foo.pl @@ -0,0 +1,5 @@ +#!perl -wd:NYTProf +# a moose using script for profiling +# Usage: perl bench/profile.pl + +require KiokuDB; diff --git a/benchmarks/cmop/lib/Bench/Accessor.pm b/benchmarks/cmop/lib/Bench/Accessor.pm new file mode 100644 index 0000000..3f30239 --- /dev/null +++ b/benchmarks/cmop/lib/Bench/Accessor.pm @@ -0,0 +1,49 @@ +#!/usr/bin/perl + +package Bench::Accessor; +use Moose; +use Moose::Util::TypeConstraints; + +eval { +coerce ArrayRef + => from HashRef + => via { [ %$_ ] }; +}; + +has class => ( + isa => "Str", + is => "ro", +); + +has construct => ( + isa => "ArrayRef", + is => "ro", + auto_deref => 1, + coerce => 1, +); + +has accessor => ( + isa => "Str", + is => "ro", +); + +has accessor_args => ( + isa => "ArrayRef", + is => "ro", + auto_deref => 1, + coerce => 1, +); + +sub code { + my $self = shift; + + my $obj = $self->class->new( $self->construct ); + my @accessor_args = $self->accessor_args; + my $accessor = $self->accessor; + + sub { $obj->$accessor( @accessor_args ) }; +} + +__PACKAGE__; + +__END__ diff --git a/benchmarks/cmop/lib/Bench/Construct.pm b/benchmarks/cmop/lib/Bench/Construct.pm new file mode 100644 index 0000000..c290304 --- /dev/null +++ b/benchmarks/cmop/lib/Bench/Construct.pm @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +package Bench::Construct; +use Moose; +use Moose::Util::TypeConstraints; + +has class => ( + isa => "Str", + is => "ro", +); + +eval { +coerce ArrayRef + => from HashRef + => via { [ %$_ ] }; +}; + +has args => ( + isa => "ArrayRef", + is => "ro", + auto_deref => 1, + coerce => 1, +); + +sub code { + my $self = shift; + + my $class = $self->class; + my @args = $self->args; + + sub { my $obj = $class->new( @args ) } +} + +__PACKAGE__; + +__END__ diff --git a/benchmarks/cmop/lib/Bench/Run.pm b/benchmarks/cmop/lib/Bench/Run.pm new file mode 100644 index 0000000..09ac1b6 --- /dev/null +++ b/benchmarks/cmop/lib/Bench/Run.pm @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +package Bench::Run; +use Moose; + +use Benchmark qw/:hireswallclock :all/; + +has classes => ( + isa => "ArrayRef", + is => "rw", + auto_deref => 1, +); + +has benchmarks => ( + isa => "ArrayRef", + is => "rw", + auto_deref => 1, +); + +has min_time => ( + isa => "Num", + is => "rw", + default => 5, +); + +sub run { + my $self = shift; + + foreach my $bench ( $self->benchmarks ) { + my $bench_class = delete $bench->{class}; + my $name = delete $bench->{name} || $bench_class; + my @bench_args = %$bench; + + eval "require $bench_class"; + die $@ if $@; + + my %res; + + foreach my $class ( $self->classes ) { + eval "require $class"; + die $@ if $@; + + my $b = $bench_class->new( @bench_args, class => $class ); + $res{$class} = countit( $self->min_time, $b->code ); + } + + print "- $name:\n"; + cmpthese( \%res ); + print "\n"; + } +} + +__PACKAGE__; + +__END__ diff --git a/benchmarks/cmop/lib/MOP/Immutable/Point.pm b/benchmarks/cmop/lib/MOP/Immutable/Point.pm new file mode 100644 index 0000000..a0d7c90 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Immutable/Point.pm @@ -0,0 +1,21 @@ + +package MOP::Immutable::Point; + +use strict; +use warnings; +use metaclass; + +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); +__PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); + +sub clear { + my $self = shift; + $self->x(0); + $self->y(0); +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ diff --git a/benchmarks/cmop/lib/MOP/Immutable/Point3D.pm b/benchmarks/cmop/lib/MOP/Immutable/Point3D.pm new file mode 100644 index 0000000..bf33cf0 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Immutable/Point3D.pm @@ -0,0 +1,22 @@ + +package MOP::Immutable::Point3D; + +use strict; +use warnings; +use metaclass; + +use base 'MOP::Point'; + +__PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); + +sub clear { + my $self = shift; + $self->SUPER::clear(); + $self->z(0); +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ diff --git a/benchmarks/cmop/lib/MOP/Installed/Point.pm b/benchmarks/cmop/lib/MOP/Installed/Point.pm new file mode 100644 index 0000000..9b6e6cf --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Installed/Point.pm @@ -0,0 +1,26 @@ + +use lib reverse @INC; + +package MOP::Installed::Point; + +use strict; +use warnings; +use metaclass; + +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); +__PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); + +sub new { + my $class = shift; + $class->meta->new_object(@_); +} + +sub clear { + my $self = shift; + $self->x(0); + $self->y(0); +} + +1; + +__END__ diff --git a/benchmarks/cmop/lib/MOP/Installed/Point3D.pm b/benchmarks/cmop/lib/MOP/Installed/Point3D.pm new file mode 100644 index 0000000..e1b66f3 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Installed/Point3D.pm @@ -0,0 +1,22 @@ + +use lib reverse @INC; + +package MOP::Installed::Point3D; + +use strict; +use warnings; +use metaclass; + +use base 'MOP::Point'; + +__PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); + +sub clear { + my $self = shift; + $self->SUPER::clear(); + $self->z(0); +} + +1; + +__END__ diff --git a/benchmarks/cmop/lib/MOP/Point.pm b/benchmarks/cmop/lib/MOP/Point.pm new file mode 100644 index 0000000..12160f7 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Point.pm @@ -0,0 +1,24 @@ + +package MOP::Point; + +use strict; +use warnings; +use metaclass; + +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); +__PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); + +sub new { + my $class = shift; + $class->meta->new_object(@_); +} + +sub clear { + my $self = shift; + $self->x(0); + $self->y(0); +} + +1; + +__END__ diff --git a/benchmarks/cmop/lib/MOP/Point3D.pm b/benchmarks/cmop/lib/MOP/Point3D.pm new file mode 100644 index 0000000..0287499 --- /dev/null +++ b/benchmarks/cmop/lib/MOP/Point3D.pm @@ -0,0 +1,20 @@ + +package MOP::Point3D; + +use strict; +use warnings; +use metaclass; + +use base 'MOP::Point'; + +__PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); + +sub clear { + my $self = shift; + $self->SUPER::clear(); + $self->z(0); +} + +1; + +__END__ diff --git a/benchmarks/cmop/lib/Plain/Point.pm b/benchmarks/cmop/lib/Plain/Point.pm new file mode 100644 index 0000000..3a69f56 --- /dev/null +++ b/benchmarks/cmop/lib/Plain/Point.pm @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +package Plain::Point; + +use strict; +use warnings; + +sub new { + my ( $class, %params ) = @_; + + return bless { + x => $params{x} || 10, + y => $params{y}, + }, $class; +} + +sub x { + my ( $self, @args ) = @_; + + if ( @args ) { + $self->{x} = $args[0]; + } + + return $self->{x}; +} + +sub y { + my ( $self, @args ) = @_; + + if ( @args ) { + $self->{y} = $args[0]; + } + + return $self->{y}; +} + +sub clear { + my $self = shift; + @{$self}{qw/x y/} = (0, 0); +} + +__PACKAGE__; + +__END__ diff --git a/benchmarks/cmop/lib/Plain/Point3D.pm b/benchmarks/cmop/lib/Plain/Point3D.pm new file mode 100644 index 0000000..87a460e --- /dev/null +++ b/benchmarks/cmop/lib/Plain/Point3D.pm @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +package Plain::Point3D; + +use strict; +use warnings; + +use base 'Plain::Point'; + +sub new { + my ( $class, %params ) = @_; + my $self = $class->SUPER::new( %params ); + $self->{z} = $params{z}; + return $self; +} + +sub z { + my ( $self, @args ) = @_; + + if ( @args ) { + $self->{z} = $args[0]; + } + + return $self->{z}; +} + +sub clear { + my $self = shift; + $self->SUPER::clear(); + $self->{z} = 0; +} + +__PACKAGE__; + +__END__ diff --git a/benchmarks/cmop/loading-benchmark.pl b/benchmarks/cmop/loading-benchmark.pl new file mode 100755 index 0000000..612ae63 --- /dev/null +++ b/benchmarks/cmop/loading-benchmark.pl @@ -0,0 +1,27 @@ +#!perl -w +use strict; +use Benchmark qw(:all); + +my ( $count, $module ) = @ARGV; +$count ||= 10; +$module ||= 'Moose'; + +my @blib + = qw(-Iblib/lib -Iblib/arch -I../Moose/blib/lib -I../Moose/blib/arch -I../Moose/lib); + +$| = 1; # autoflush + +print 'Installed: '; +system $^X, '-le', 'require Moose; print $INC{q{Moose.pm}}'; + +print 'Blead: '; +system $^X, @blib, '-le', 'require Moose; print $INC{q{Moose.pm}}'; + +cmpthese timethese $count => { + released => sub { + system( $^X, '-e', "require $module" ) == 0 or die; + }, + blead => sub { + system( $^X, @blib, '-e', "require $module" ) == 0 or die; + }, +}; diff --git a/benchmarks/cmop/profile.pl b/benchmarks/cmop/profile.pl new file mode 100755 index 0000000..4ea5b01 --- /dev/null +++ b/benchmarks/cmop/profile.pl @@ -0,0 +1,25 @@ +#!perl -w +# Usage: perl bench/profile.pl (no other options including -Mblib are reqired) + +use strict; + +my $script = 'bench/foo.pl'; + +my $branch = do { + open my $in, '.git/HEAD' or die "Cannot open .git/HEAD: $!"; + my $s = scalar <$in>; + chomp $s; + $s =~ s{^ref: \s+ refs/heads/}{}xms; + $s =~ s{/}{_}xmsg; + $s; +}; + +print "Profiling $branch ...\n"; + +my @cmd = ( $^X, '-Iblib/lib', '-Iblib/arch', $script ); +print "> @cmd\n"; +system(@cmd) == 0 or die "Cannot profile"; + +@cmd = ( $^X, '-S', 'nytprofhtml', '--out', "nytprof-$branch" ); +print "> @cmd\n"; +system(@cmd) == 0 or die "Cannot profile"; diff --git a/benchmarks/cmop/run_yml.pl b/benchmarks/cmop/run_yml.pl new file mode 100644 index 0000000..341b640 --- /dev/null +++ b/benchmarks/cmop/run_yml.pl @@ -0,0 +1,18 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use YAML::Syck; +use Bench::Run; + +my $data = LoadFile( shift || "$FindBin::Bin/all.yml" ); + +foreach my $bench ( @$data ) { + print "== ", delete $bench->{name}, " ==\n\n"; + Bench::Run->new( %$bench )->run; + print "\n\n"; +} diff --git a/benchmarks/immutable.pl b/benchmarks/immutable.pl new file mode 100644 index 0000000..0263404 --- /dev/null +++ b/benchmarks/immutable.pl @@ -0,0 +1,99 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Benchmark qw[cmpthese]; + +use Moose::Util::TypeConstraints; + +{ + package Foo; + use Moose; + Foo->meta->make_immutable(debug => 0); +} + +coerce 'Foo' + => from 'ArrayRef' + => via { Foo->new(@{$_}) }; + +{ + package Foo::Normal; + use Moose; + + has 'default' => (is => 'rw', default => 10); + has 'default_sub' => (is => 'rw', default => sub { [] }); + has 'lazy' => (is => 'rw', default => 10, lazy => 1); + has 'required' => (is => 'rw', required => 1); + has 'weak_ref' => (is => 'rw', weak_ref => 1); + has 'type_constraint' => (is => 'rw', isa => 'Foo'); + has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1); + + package Bar::Normal; + use Moose; + + extends 'Foo::Normal'; + + has 'default_w_type_constraint' => ( + is => 'rw', + isa => 'Int', + default => 10, + ); +} + +{ + package Foo::Immutable; + use Moose; + + has 'default' => (is => 'rw', default => 10); + has 'default_sub' => (is => 'rw', default => sub { [] }); + has 'lazy' => (is => 'rw', default => 10, lazy => 1); + has 'required' => (is => 'rw', required => 1); + has 'weak_ref' => (is => 'rw', weak_ref => 1); + has 'type_constraint' => (is => 'rw', isa => 'Foo'); + has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1); + + #sub BUILD { + # # ... + #} + + Foo::Immutable->meta->make_immutable(debug => 0); + + package Bar::Immutable; + use Moose; + + extends 'Foo::Immutable'; + + has 'default_w_type_constraint' => ( + is => 'rw', + isa => 'Int', + default => 10, + ); + + Bar::Immutable->meta->make_immutable(debug => 0); +} + +#__END__ + +my $foo = Foo->new; + +cmpthese(10_000, + { + 'normal' => sub { + Foo::Normal->new( + required => 'BAR', + type_constraint => $foo, + coercion => [], + weak_ref => {}, + ); + }, + 'immutable' => sub { + Foo::Immutable->new( + required => 'BAR', + type_constraint => $foo, + coercion => [], + weak_ref => {}, + ); + }, + } +);
\ No newline at end of file diff --git a/benchmarks/lotsa-classes.pl b/benchmarks/lotsa-classes.pl new file mode 100644 index 0000000..c21decd --- /dev/null +++ b/benchmarks/lotsa-classes.pl @@ -0,0 +1,78 @@ +#!/usr/bin/env perl + +use warnings FATAL => 'all'; +use strict; +use File::Temp; +use Path::Class; + +my $number_of_classes = shift || 1500; +my $number_of_attributes = shift || 20; +my $t = shift || File::Temp->newdir; +my $tmp = dir($t); +$tmp->rmtree; +$tmp->mkpath; +(-d $tmp) or die "not a dir: $tmp"; +#print "$tmp\n"; + +my %class_writer = ( + 'Moose' => sub { + my $name = shift; + my $attrs = join '', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; + return qq{package $name;\nuse Moose;\n$attrs\n1;\n__END__\n}; + }, + 'MooseImmutable' => sub { + my $name = shift; + my $attrs = join '', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; + return qq{package $name;\nuse Moose;\n$attrs\n__PACKAGE__->meta->make_immutable;\n1;\n__END__\n}; + }, + 'Moo' => sub { + my $name = shift; + my $attrs = join'', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; + return qq{package $name;\nuse Moo;\n$attrs\n1;\n__END__\n}; + }, + 'Mo' => sub { + my $name = shift; + my $attrs = join'', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; + return qq{package $name;\nuse Mo;\n$attrs\n1;\n__END__\n}; + }, + 'Mouse' => sub { + my $name = shift; + my $attrs = join'', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; + return qq{package $name;\nuse Mouse;\n$attrs\n1;\n__END__\n}; + }, + 'plain-package' => sub { + my $name = shift; + my $attrs = join'', map { "sub $_ {}\n" } @_; + return qq{package $name;\n$attrs\n1;\n__END__\n}; + }, +); + +my $class_prefix = 'TmpClassThingy'; +my %lib_map; +my @attribute_names = map { 'a' . $_ } 1 .. $number_of_attributes; +for my $module (sort keys %class_writer) { + my $lib = $tmp->subdir($module . '-lib'); + $lib->mkpath; + my $all_fh = $lib->file('All.pm')->openw; + for my $n (1 .. $number_of_classes) { + my $class_name = $class_prefix . $n; + my $fh = $lib->file($class_name . '.pm')->openw; + $fh->say($class_writer{$module}->($class_name, @attribute_names)) or die; + $fh->close or die; + $all_fh->say("use $class_name;") or die; + } + $all_fh->say('1;') or die; + $all_fh->close or die; + $lib_map{$module} = $lib; +} + +#$DB::single = 1; +for my $module (sort keys %lib_map) { + my $lib = $lib_map{$module}; + print "$module\n"; + my $cmd = "time -p $^X -I$lib -MAll -e '1'"; + `$cmd > /dev/null 2>&1`; # to cache +# print "$cmd\n"; + system($cmd); + print "\n"; +} diff --git a/benchmarks/method_modifiers.pl b/benchmarks/method_modifiers.pl new file mode 100755 index 0000000..ac860a9 --- /dev/null +++ b/benchmarks/method_modifiers.pl @@ -0,0 +1,116 @@ +#!perl + +### MODULES + +{ + package PlainParent; + sub new { bless {} => shift } + sub method { "P" } +} +{ + package MooseParent; + use Moose; + sub method { "P" } +} + +{ + package CMMChild::Before; + use Class::Method::Modifiers; + use base 'PlainParent'; + + before method => sub { "B" }; +} +{ + package MooseBefore; + use Moose; + extends 'MooseParent'; + + before method => sub { "B" }; +} + +{ + package CMMChild::Around; + use Class::Method::Modifiers; + use base 'PlainParent'; + + around method => sub { shift->() . "A" }; +} +{ + package MooseAround; + use Moose; + extends 'MooseParent'; + + around method => sub { shift->() . "A" }; +} + +{ + package CMMChild::AllThree; + use Class::Method::Modifiers; + use base 'PlainParent'; + + before method => sub { "B" }; + around method => sub { shift->() . "A" }; + after method => sub { "Z" }; +} +{ + package MooseAllThree; + use Moose; + extends 'MooseParent'; + + before method => sub { "B" }; + around method => sub { shift->() . "A" }; + after method => sub { "Z" }; +} +{ + package CMM::Install; + use Class::Method::Modifiers; + use base 'PlainParent'; +} +{ + package Moose::Install; + use Moose; + extends 'MooseParent'; +} + +use Benchmark qw(cmpthese); +use Benchmark ':hireswallclock'; + +my $rounds = -5; + +my $cmm_before = CMMChild::Before->new(); +my $cmm_around = CMMChild::Around->new(); +my $cmm_allthree = CMMChild::AllThree->new(); + +my $moose_before = MooseBefore->new(); +my $moose_around = MooseAround->new(); +my $moose_allthree = MooseAllThree->new(); + +print "\nBEFORE\n"; +cmpthese($rounds, { + Moose => sub { $moose_before->method() }, + ClassMethodModifiers => sub { $cmm_before->method() }, +}, 'noc'); + +print "\nAROUND\n"; +cmpthese($rounds, { + Moose => sub { $moose_around->method() }, + ClassMethodModifiers => sub { $cmm_around->method() }, +}, 'noc'); + +print "\nALL THREE\n"; +cmpthese($rounds, { + Moose => sub { $moose_allthree->method() }, + ClassMethodModifiers => sub { $cmm_allthree->method() }, +}, 'noc'); + +print "\nINSTALL AROUND\n"; +cmpthese($rounds, { + Moose => sub { + package Moose::Install; + Moose::Install::around(method => sub {}); + }, + ClassMethodModifiers => sub { + package CMM::Install; + CMM::Install::around(method => sub {}); + }, +}, 'noc'); diff --git a/benchmarks/moose_bench.pl b/benchmarks/moose_bench.pl new file mode 100755 index 0000000..b8dc426 --- /dev/null +++ b/benchmarks/moose_bench.pl @@ -0,0 +1,152 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Time::HiRes 'time'; +use List::Util 'sum'; +use IPC::System::Simple 'system'; +use autodie; +use Parse::BACKPAN::Packages; +use LWP::Simple; +use Archive::Tar; +use Path::Tiny; + +my $backpan = Parse::BACKPAN::Packages->new; +my @cmops = $backpan->distributions('Class-MOP'); +my @mooses = $backpan->distributions('Moose'); + +my $cmop_version = 0; +my $cmop_dir; + +my $base = "http://backpan.cpan.org/"; + +my %time; +my %mem; + +open my $output, ">", "moose_bench.txt"; + +for my $moose (@mooses) { + my $moose_dir = build($moose); + + # Find the CMOP dependency + my $makefile = path("$moose_dir/Makefile.PL")->slurp_utf8; + my ($cmop_dep) = $makefile =~ /Class::MOP.*?([0-9._]+)/ + or die "Unable to find Class::MOP version dependency in $moose_dir/Makefile.PL"; + + # typo? + $cmop_dep = '0.64_07' if $cmop_dep eq '0.6407'; + + # nonexistent dev releases? + $cmop_dep = '0.79' if $cmop_dep eq '0.78_02'; + $cmop_dep = '0.83' if $cmop_dep eq '0.82_01'; + + bump_cmop($cmop_dep, $moose); + + warn "Building $moose_dir"; + eval { + system("(cd '$moose_dir' && '$^X' '-I$cmop_dir/lib' Makefile.PL && make && sudo make install) >/dev/null"); + + my @times; + for (1 .. 5) { + my $start = time; + system( + $^X, + "-I$moose_dir/lib", + "-I$cmop_dir/lib", + '-e', 'package Class; use Moose;', + ); + push @times, time - $start; + } + + $time{$moose->version} = sum(@times) / @times; + $mem{$moose->version} = qx[$^X -I$moose_dir/lib -I$cmop_dir/lib -MGTop -e 'my (\$gtop, \$before); BEGIN { \$gtop = GTop->new; \$before = \$gtop->proc_mem(\$\$)->size; } package Class; use Moose; print \$gtop->proc_mem(\$\$)->size - \$before']; + my $line = sprintf "%7s: %0.4f (%s), %d bytes\n", + $moose->version, + $time{$moose->version}, + join(', ', map { sprintf "%0.4f", $_ } @times), + $mem{$moose->version}; + print $output $line; + }; + warn $@ if $@; +} + +require Chart::Clicker; +require Chart::Clicker::Data::Series; +require Chart::Clicker::Data::DataSet; +my @versions = sort keys %time; +my @startups = map { $time{$_} } @versions; +my @memories = map { int($mem{$_} / 1024) } @versions; +my @keys = (0..$#versions); +my $cc = Chart::Clicker->new(width => 900, height => 400); +my $sutime = Chart::Clicker::Data::Series->new( + values => \@startups, + keys => \@keys, + name => 'Startup Time', +); +my $def = $cc->get_context('default'); +$def->domain_axis->tick_values(\@keys); +$def->domain_axis->tick_labels(\@versions); +$def->domain_axis->tick_label_angle(1.57); +$def->domain_axis->tick_font->size(8); +$def->range_axis->fudge_amount('0.05'); + +my $context = Chart::Clicker::Context->new(name => 'memory'); +$context->range_axis->tick_values([qw(1024 2048 3072 4096 5120)]); +$context->range_axis->format('%d'); +$context->domain_axis->hidden(1); +$context->range_axis->fudge_amount('0.05'); +$cc->add_to_contexts($context); + +my $musage = Chart::Clicker::Data::Series->new( + values => \@memories, + keys => \@keys, + name => 'Memory Usage (kb)' +); + +my $ds1 = Chart::Clicker::Data::DataSet->new(series => [ $sutime ]); +my $ds2 = Chart::Clicker::Data::DataSet->new(series => [ $musage ]); +$ds2->context('memory'); + +$cc->add_to_datasets($ds1); +$cc->add_to_datasets($ds2); +$cc->write_output('moose_bench.png'); + +sub bump_cmop { + my $expected = shift; + my $moose = shift; + + return $cmop_dir if $cmop_version eq $expected; + + my @orig_cmops = @cmops; + shift @cmops until !@cmops || $cmops[0]->version eq $expected; + + die "Ran out of cmops, wanted $expected for " + . $moose->distvname + . " (had " . join(', ', map { $_->version } @orig_cmops) . ")" + if !@cmops; + + $cmop_version = $cmops[0]->version; + $cmop_dir = build($cmops[0]); + + warn "Building $cmop_dir"; + system("(cd '$cmop_dir' && '$^X' Makefile.PL && make && sudo make install) >/dev/null"); + + return $cmop_dir; +} + +sub build { + my $dist = shift; + my $distvname = $dist->distvname; + return $distvname if -d $distvname; + + warn "Downloading $distvname"; + my $tarball = get($base . $dist->prefix); + open my $handle, '<', \$tarball; + + my $tar = Archive::Tar->new; + $tar->read($handle); + $tar->extract; + + my ($arbitrary_file) = $tar->list_files; + (my $directory = $arbitrary_file) =~ s{/.*}{}; + return $directory; +} diff --git a/benchmarks/simple_class.pl b/benchmarks/simple_class.pl new file mode 100644 index 0000000..f0061f1 --- /dev/null +++ b/benchmarks/simple_class.pl @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Benchmark::Forking qw[cmpthese]; + +=pod + +This compares the burden of a basic Moose +class to a basic Class::MOP class. + +It is worth noting that the basic Moose +class will also create a type constraint +as well as export many subs, so this comparison +is really not fair :) + +=cut + +cmpthese(5_000, + { + 'w/out_moose' => sub { + eval 'package Bar; use metaclass;'; + }, + 'w_moose' => sub { + eval 'package Baz; use Moose;'; + }, + } +); + +1;
\ No newline at end of file diff --git a/benchmarks/simple_compile.pl b/benchmarks/simple_compile.pl new file mode 100644 index 0000000..4b5b4a8 --- /dev/null +++ b/benchmarks/simple_compile.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Benchmark::Forking qw[cmpthese]; + +=pod + +This compare the overhead of Class::MOP +to the overhead of Moose. + +The goal here is to see how much more +startup cost Moose adds to Class::MOP. + +NOTE: +This benchmark may not be all that +relevant really, but it's helpful to +see maybe. + +=cut + +cmpthese(5_000, + { + 'w/out_moose' => sub { + eval 'use Class::MOP;'; + }, + 'w_moose' => sub { + eval 'use Moose;'; + }, + } +); + +1;
\ No newline at end of file diff --git a/benchmarks/simple_constructor.pl b/benchmarks/simple_constructor.pl new file mode 100644 index 0000000..def63ed --- /dev/null +++ b/benchmarks/simple_constructor.pl @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +my $num_iterations = shift || 100; + +{ + package Foo; + use Moose; + + has 'default' => (is => 'rw', default => 10); + has 'default_sub' => (is => 'rw', default => sub { [] }); + has 'lazy' => (is => 'rw', default => 10, lazy => 1); + has 'required' => (is => 'rw', required => 1); + has 'weak_ref' => (is => 'rw', weak_ref => 1); + has 'type_constraint' => (is => 'rw', isa => 'ArrayRef'); +} + +foreach (0 .. $num_iterations) { + my $foo = Foo->new( + required => 'BAR', + type_constraint => [], + weak_ref => {}, + ); +}
\ No newline at end of file diff --git a/benchmarks/type_constraints.pl b/benchmarks/type_constraints.pl new file mode 100644 index 0000000..e9b29f8 --- /dev/null +++ b/benchmarks/type_constraints.pl @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Benchmark qw[cmpthese]; + +=pod + +This benchmark compares the overhead of a +auto-created type constraint vs. none at +all vs. a custom-created type. + +=cut + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has 'baz' => (is => 'rw'); + has 'bar' => (is => 'rw', isa => 'Foo'); +} + +{ + package Bar; + + sub new { bless {} => __PACKAGE__ } + sub bar { + my $self = shift; + $self->{bar} = shift if @_; + $self->{bar}; + } +} + +my $foo = Foo->new; +my $bar = Bar->new; + +cmpthese(200_000, + { + 'hand coded' => sub { + $bar->bar($bar); + }, + 'w/out_constraint' => sub { + $foo->baz($foo); + }, + 'w_constraint' => sub { + $foo->bar($foo); + }, + } +); + +1;
\ No newline at end of file diff --git a/benchmarks/type_constraints2.pl b/benchmarks/type_constraints2.pl new file mode 100644 index 0000000..7c97b99 --- /dev/null +++ b/benchmarks/type_constraints2.pl @@ -0,0 +1,153 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Benchmark qw[timethese]; + +=pod + +This benchmark is designed to measure how long things with type constraints +take (constructors, accessors). It was created to measure the impact of +inlining type constraints. + +=cut + +{ + package Thing; + + use Moose; + + has int => ( + is => 'rw', + isa => 'Int', + ); + + has str => ( + is => 'rw', + isa => 'Str', + ); + + has fh => ( + is => 'rw', + isa => 'FileHandle', + ); + + has object => ( + is => 'rw', + isa => 'Object', + ); + + has a_int => ( + is => 'rw', + isa => 'ArrayRef[Int]', + ); + + has a_str => ( + is => 'rw', + isa => 'ArrayRef[Str]', + ); + + has a_fh => ( + is => 'rw', + isa => 'ArrayRef[FileHandle]', + ); + + has a_object => ( + is => 'rw', + isa => 'ArrayRef[Object]', + ); + + has h_int => ( + is => 'rw', + isa => 'HashRef[Int]', + ); + + has h_str => ( + is => 'rw', + isa => 'HashRef[Str]', + ); + + has h_fh => ( + is => 'rw', + isa => 'HashRef[FileHandle]', + ); + + has h_object => ( + is => 'rw', + isa => 'HashRef[Object]', + ); + + __PACKAGE__->meta->make_immutable; +} + +{ + package Simple; + use Moose; + + has str => ( + is => 'rw', + isa => 'Str', + ); + + __PACKAGE__->meta->make_immutable; +} + +my @ints = 1 .. 10; +my @strs = 'a' .. 'j'; +my @fhs = map { my $fh; open $fh, '<', $0 or die; $fh; } 1 .. 10; +my @objects = map { Thing->new } 1 .. 10; + +my %ints = map { $_ => $_ } @ints; +my %strs = map { $_ => $_ } @ints; +my %fhs = map { $_ => $_ } @fhs; +my %objects = map { $_ => $_ } @objects; + +my $thing = Thing->new; +my $simple = Simple->new; + +timethese( + 1_000_000, { + constructor_simple => sub { + Simple->new( str => $strs[0] ); + }, + accessors_simple => sub { + $simple->str( $strs[0] ); + }, + } +); + +timethese( + 20_000, { + constructor_all => sub { + Thing->new( + int => $ints[0], + str => $strs[0], + fh => $fhs[0], + object => $objects[0], + a_int => \@ints, + a_str => \@strs, + a_fh => \@fhs, + a_object => \@objects, + h_int => \%ints, + h_str => \%strs, + h_fh => \%fhs, + h_object => \%objects, + ); + }, + accessors_all => sub { + $thing->int( $ints[0] ); + $thing->str( $strs[0] ); + $thing->fh( $fhs[0] ); + $thing->object( $objects[0] ); + $thing->a_int( \@ints ); + $thing->a_str( \@strs ); + $thing->a_fh( \@fhs ); + $thing->a_object( \@objects ); + $thing->h_int( \%ints ); + $thing->h_str( \%strs ); + $thing->h_fh( \%fhs ); + $thing->h_object( \%objects ); + }, + } +); diff --git a/bin/moose-outdated b/bin/moose-outdated new file mode 100644 index 0000000..341daf1 --- /dev/null +++ b/bin/moose-outdated @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +use strict; +use warnings; +# PODNAME: moose-outdated + +# this script was generated with Dist::Zilla::Plugin::Conflicts 0.17 + +use Getopt::Long; +use Moose::Conflicts; + +my $verbose; +GetOptions( 'verbose|v' => \$verbose ); + +if ($verbose) { + Moose::Conflicts->check_conflicts; +} +else { + my @conflicts = Moose::Conflicts->calculate_conflicts; + print "$_\n" for map { $_->{package} } @conflicts; + exit @conflicts; +} diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..37924c1 --- /dev/null +++ b/dist.ini @@ -0,0 +1,464 @@ +name = Moose +author = Stevan Little <stevan.little@iinteractive.com> +author = Dave Rolsky <autarch@urth.org> +author = Jesse Luehrs <doy@tozt.net> +author = Shawn M Moore <code@sartak.org> +author = יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> +author = Karen Etheridge <ether@cpan.org> +author = Florian Ragwitz <rafl@debian.org> +author = Hans Dieter Pearcey <hdp@weftsoar.net> +author = Chris Prather <chris@prather.org> +author = Matt S Trout <mst@shadowcat.co.uk> +license = Perl_5 +copyright_holder = Infinity Interactive, Inc. +copyright_year = 2006 + +; $VERSION will be extracted from lib/Moose.pm, +; or override it with $ENV{V} + +[EnsurePrereqsInstalled] +:version = 0.003 +build_phase = release ; be nice to travis +type = requires +type = recommends + +[Git::GatherDir] +exclude_match = ^t/recipes/(?!basics_genome_overloadingsubtypesandcoercion) +exclude_filename = Makefile.PL +exclude_filename = LICENSE + +[MetaYAML] +[MetaJSON] +[License] +[ExecDir] +[ShareDir] + +; authordep Dist::Zilla::Plugin::MakeMaker::Awesome +[=inc::MakeMaker] +default_jobs = 9 + +[Manifest] + +[MetaConfig] + +[=inc::SimpleAuthority] + +[MetaResources] +bugtracker.web = https://rt.cpan.org/Dist/Display.html?Name=Moose +bugtracker.mailto = bug-moose@rt.cpan.org +homepage = http://moose.perl.org/ +repository.url = git://github.com/moose/Moose.git +repository.web = https://github.com/moose/Moose +repository.type = git +x_IRC = irc://irc.perl.org/#moose +x_MailingList = http://lists.perl.org/list/moose.html + +[FileFinder::ByName / PodModules] +dir = lib +file = *.pod + +[FileFinder::Filter / ModulesSansPod] +finder = :InstallModules +skip = \.pod$ + +[FileFinder::Filter / VersionedModules] +finder = :InstallModules +skip = \.pod$ +skip = ^lib/Moose/Conflicts.pm$ + +[=inc::SimpleProvides] +finder = PodModules + +[MetaProvides::Package] +meta_noindex = 1 +:version = 1.15000002 +finder = ModulesSansPod ; to avoid "No namespaces detected in file..." spewage + +[MetaNoIndex] +package = Class::MOP::Class::Immutable::Trait +package = Class::MOP::Deprecated +package = Class::MOP::MiniTrait +package = Class::MOP::Mixin +namespace = Class::MOP::Mixin +package = Moose::Deprecated +package = Moose::Meta::Attribute::Native::Trait +package = Moose::Meta::Class::Immutable::Trait +package = Moose::Meta::Method::Accessor::Native +namespace = Moose::Meta::Method::Accessor::Native +namespace = Moose::Meta::Mixin +package = Moose::Meta::Object::Trait +package = Moose::Util::TypeConstraints::Builtins +directory = author +directory = benchmarks +directory = doc +directory = inc + +[Git::Contributors] + +[SurgicalPodWeaver] +:version = 0.0023 +replacer = replace_with_comment +post_code_replacer = replace_with_nothing + +[RewriteVersion] +finder = VersionedModules + +[Git::Describe] +:version = 0.004 +on_package_line = 1 + +; authordep Test::Inline +; authordep File::Find::Rule +; authordep Test::Inline::Extract +[=inc::ExtractInlineTests] + +[PromptIfStale] +phase = release +check_all_prereqs = 1 +check_all_plugins = 1 + +[Test::EOL] +:version = 0.14 +[PodSyntaxTests] +[Test::NoTabs] +[MetaTests] +[Test::Kwalitee] +skiptest = use_strict ; temporary, until RT#94468 is fixed + +[MojibakeTests] +[RunExtraTests] +default_jobs = 9 + +[Test::ReportPrereqs] +include = Algorithm::C3 +include = DBM::Deep +include = DateTime +include = DateTime::Calendar::Mayan +include = DateTime::Format::MySQL +include = Declare::Constraints::Simple +include = Dist::CheckConflicts +include = HTTP::Headers +include = IO::File +include = IO::String +include = Locale::US +include = Module::Refresh +include = MooseX::NonMoose +include = Params::Coerce +include = Regexp::Common +include = SUPER +include = Test::Deep +include = Test::DependentModules +include = Test::LeakTrace +include = Test::Output +include = URI + +[Test::CPAN::Changes] + +[Test::Compile] +:version = 2.037 +phase = develop +filename = xt/release/00-compile.t +bail_out_on_fail = 1 +; this serves as a TODO list for getting all modules to load independently -- +; see RT#89536 +skip = ^Class::MOP::Attribute$ +skip = ^Class::MOP::Class$ +skip = ^Class::MOP::Method::Accessor$ +skip = ^Class::MOP::Method::Constructor$ +skip = ^Class::MOP::Method::Inlined$ +skip = ^Class::MOP::Method::Wrapped$ +skip = ^Class::MOP::Mixin::HasAttributes$ +skip = ^Class::MOP::Module$ +skip = ^Class::MOP::Package$ +skip = ^Moose::Meta::Attribute$ +skip = ^Moose::Meta::Attribute::Native$ +skip = ^Moose::Meta::Mixin::AttributeCore$ +skip = ^Moose::Meta::Role::Attribute$ +skip = ^Moose::Meta::TypeConstraint::Class$ +skip = ^Moose::Meta::TypeConstraint::DuckType$ +skip = ^Moose::Meta::TypeConstraint::Enum$ +skip = ^Moose::Meta::TypeConstraint::Parameterizable$ +skip = ^Moose::Meta::TypeConstraint::Parameterized$ +skip = ^Moose::Meta::TypeConstraint::Role$ +skip = ^Moose::Meta::TypeConstraint::Union$ + +[=inc::CheckReleaseType] +[CheckVersionIncrement] + +; we would like to have this, but currently there are false negatives: +; https://rt.cpan.org/Ticket/Display.html?id=87883 +; https://rt.cpan.org/Ticket/Display.html?id=87884 +;[Test::MinimumVersion] +;:version = 2.000003 +;max_target_perl = 5.008003 + +[CheckChangesHasContent] +;[CheckPrereqsIndexed] + +; all runtime deps must be author deps +[Prereqs] + Carp = 1.22 +;authordep Carp = 1.22 + Class::Load = 0.09 +;authordep Class::Load = 0.09 + Class::Load::XS = 0.01 +;authordep Class::Load::XS = 0.01 + Data::OptList = 0.107 +;authordep Data::OptList = 0.107 + Devel::GlobalDestruction = 0 +;authordep Devel::GlobalDestruction = 0 + Devel::OverloadInfo = 0.002 +;authordep Devel::OverloadInfo = 0.002 + Devel::StackTrace = 1.33 +;authordep Devel::StackTrace = 1.33 + Eval::Closure = 0.04 +;authordep Eval::Closure = 0.04 + List::MoreUtils = 0.28 +;authordep List::MoreUtils = 0.28 + List::Util = 1.35 +;authordep List::Util = 1.35 + MRO::Compat = 0.05 +;authordep MRO::Compat = 0.05 + Module::Runtime = 0.014 +;authordep Module::Runtime = 0.014 + Module::Runtime::Conflicts = 0.002 +;authordep Module::Runtime::Conflicts = 0.002 + Package::DeprecationManager = 0.11 +;authordep Package::DeprecationManager = 0.11 + Package::Stash = 0.32 +;authordep Package::Stash = 0.32 + Package::Stash::XS = 0.24 +;authordep Package::Stash::XS = 0.24 + Params::Util = 1.00 +;authordep Params::Util = 1.00 + Scalar::Util = 1.19 +;authordep Scalar::Util = 1.19 + Sub::Exporter = 0.980 +;authordep Sub::Exporter = 0.980 + Sub::Identify = 0 +;authordep Sub::Identify = 0 + Sub::Name = 0.05 +;authordep Sub::Name = 0.05 + Task::Weaken = 0 +;authordep Task::Weaken = 0 + Try::Tiny = 0.17 +;authordep Try::Tiny = 0.17 + parent = 0.223 +;authordep parent = 0.223 + perl = 5.8.3 +;authordep perl = 5.8.3 + strict = 1.03 +;authordep strict = 1.03 + warnings = 1.03 +;authordep warnings = 1.03 + +[Prereqs / TestRequires] +Test::CleanNamespaces = 0.13 +Test::Fatal = 0.001 +Test::More = 0.88 +Test::Requires = 0.05 +Test::Warnings = 0.016 + +; all configure deps must be author deps +[Prereqs / ConfigureRequires] + ExtUtils::CBuilder = 0.27 +;authordep ExtUtils::CBuilder = 0.27 + File::Spec = 0 +;authordep File::Spec = 0 +;Config = 0 ; not actually in 02packages.details.txt!!! + +[Prereqs::AuthorDeps] +relation = suggests +exclude = inc::CheckAuthorDeps +exclude = inc::CheckDelta +exclude = inc::CheckReleaseType +exclude = inc::Clean +exclude = inc::ExtractInlineTests +exclude = inc::GenerateDocs +exclude = inc::GitUpToDate +exclude = inc::MMHelper +exclude = inc::MakeMaker +exclude = inc::MyInline +exclude = inc::SimpleAuthority +exclude = inc::SimpleProvides +exclude = inc::TestRelease + +; mostly, these are things needed by xt tests +[Prereqs / DevelopRequires] +Algorithm::C3 = 0 +Class::Load = 0.07 +DBM::Deep = 1.003 +Data::Visitor = 0 +DateTime = 0 +DateTime::Calendar::Mayan = 0 +DateTime::Format::MySQL = 0 +Declare::Constraints::Simple = 0 +ExtUtils::MakeMaker::Dist::Zilla::Develop = 0 +File::Find::Rule = 0 +HTTP::Headers = 0 +IO::File = 0 +IO::String = 0 +Locale::US = 0 +Module::CPANTS::Analyse = 0.92 +Module::Refresh = 0 +MooseX::MarkAsMethods = 0 +MooseX::NonMoose = 0 +PadWalker = 0 +Params::Coerce = 0 +Regexp::Common = 0 +SUPER = 1.10 +Specio = 0.10 +Test::Deep = 0 +;Test::DependentModules = 0.13 ; bad dep chain, used by a disabled test. +Test::Inline = 0 +Test::Kwalitee = 1.15 +Test::LeakTrace = 0 +Test::Memory::Cycle = 0 +Test::Output = 0 +Test::Pod::Coverage = 1.04 +Test::Spelling = 0 +URI = 0 +blib = 0 + +[Prereqs / RuntimeSuggests] +; this needs to be installed *after*, since it deps on Moose +; remove this if this is an issue +Devel::PartialDump = 0.14 + +[Conflicts] +:version = 0.16 +-script = bin/moose-outdated +Catalyst = 5.90049999 +Config::MVP = 2.200004 +Devel::REPL = 1.003020 +Dist::Zilla::Plugin::Git = 2.016 +Fey = 0.36 +Fey::ORM = 0.42 +File::ChangeNotify = 0.15 +HTTP::Throwable = 0.017 +KiokuDB = 0.51 +Markdent = 0.16 +Mason = 2.18 +MooseX::ABC = 0.05 +MooseX::Aliases = 0.08 +MooseX::AlwaysCoerce = 0.13 +MooseX::App = 1.22 +MooseX::Attribute::Deflator = 2.1.7 +MooseX::Attribute::Dependent = 1.1.0 +MooseX::Attribute::Prototype = 0.10 +MooseX::AttributeHelpers = 0.22 +MooseX::AttributeIndexes = 1.0.0 +MooseX::AttributeInflate = 0.02 +MooseX::CascadeClearing = 0.03 +MooseX::ClassAttribute = 0.26 +MooseX::Constructor::AllErrors = 0.021 +MooseX::Declare = 0.35 +MooseX::FollowPBP = 0.02 +MooseX::Getopt = 0.56 +MooseX::InstanceTracking = 0.04 +MooseX::LazyRequire = 0.06 +MooseX::Meta::Attribute::Index = 0.04 +MooseX::Meta::Attribute::Lvalue = 0.05 +MooseX::Method::Signatures = 0.44 +MooseX::MethodAttributes = 0.22 +MooseX::NonMoose = 0.24 +MooseX::Object::Pluggable = 0.0011 +MooseX::POE = 0.214 +MooseX::Params::Validate = 0.05 +MooseX::PrivateSetters = 0.03 +MooseX::Role::Cmd = 0.06 +MooseX::Role::Parameterized = 1.00 +MooseX::Role::WithOverloading = 0.14 +MooseX::Runnable = 0.03 +MooseX::Scaffold = 0.05 +MooseX::SemiAffordanceAccessor = 0.05 +MooseX::SetOnce = 0.100473 +MooseX::Singleton = 0.25 +MooseX::SlurpyConstructor = 1.1 +MooseX::Storage = 0.42 +MooseX::StrictConstructor = 0.12 +MooseX::Traits = 0.11 +MooseX::Types = 0.19 +MooseX::Types::Parameterizable = 0.05 +MooseX::Types::Set::Object = 0.03 +MooseX::Types::Signal = 1.101930 +MooseX::UndefTolerant = 0.11 +PRANG = 0.14 +Pod::Elemental = 0.093280 +Pod::Weaver = 3.101638 +Reaction = 0.002003 +Test::Able = 0.10 +Test::CleanNamespaces = 0.03 +Test::Moose::More = 0.022 +Test::TempDir = 0.05 +Throwable = 0.102080 +namespace::autoclean = 0.08 + +[Test::CheckBreaks] +conflicts_module = Moose::Conflicts + +; authordep Dist::Zilla::Util::AuthorDeps = 5.021 +; authordep CPAN::Meta::Requirements +; authordep Test::Deep +[=inc::CheckAuthorDeps] + +[=inc::CheckDelta] +[=inc::GitUpToDate] + +[Git::Remote::Check] +branch = stable/2.14 +remote_branch = stable/2.14 + +[Git::CheckFor::CorrectBranch] +release_branch = stable/2.14 + +[Git::Check] +allow_dirty = + +[TestRelease] +[UploadToCPAN] + +[CopyFilesFromRelease] +filename = Changes +filename = LICENSE + +[Git::Commit / release snapshot] +allow_dirty = Changes +allow_dirty = LICENSE +commit_msg = %N-%v%t%n%n%c + +[Git::Tag] +tag_format = %v +tag_message = %v%t + +[BumpVersionAfterRelease] +finder = VersionedModules + +[NextRelease] +:version = 5.033 +format = %-7v %{yyyy-MM-dd}d%{ (TRIAL RELEASE)}T + +[Git::Commit / increment version] +allow_dirty = Changes +allow_dirty_match = ^lib/.*\.pm$ +commit_msg = increment version after release + +[Git::Push] + +; note: this is going to die if releasing from an older release branch (the +; merge won't go in cleanly) +[Run::AfterRelease] +run = git checkout master +run = git merge --ff-only stable/2.14 +run = git push + +; authordep Class::Load +; authordep IPC::System::Simple +; authordep File::pushd +; authordep Path::Tiny +[=inc::GenerateDocs] + +[=inc::Clean] + +; last, so all before-release checks can occur first before prompting +[ConfirmRelease] diff --git a/doc/moosex-compile b/doc/moosex-compile new file mode 100644 index 0000000..7d0a049 --- /dev/null +++ b/doc/moosex-compile @@ -0,0 +1,176 @@ +MooseX-Compile, wherein Yuval explains how MooseX::Compile is supposed to work and what needs doing. + +TODO: PLEASE EDIT ME + +19:11 <obra> hiya +19:12 <nothingmuch> hola +19:13 <obra> so, my empty mail was an attempted abort +19:13 <obra> but was going to be "MX::Compile doesn't depend on MX::Compile::CLI. should it?" +19:13 <nothingmuch> ah, ok =) +19:13 <obra> but i'm without my laptop, so i couldn't actually check my assumption +19:14 <nothingmuch> no, because MX::Compile::CLI is "just a a frontend" and at the time the dependencies were a little sketchy +19:14 <nothingmuch> they've since matured, so maybe it should dep +19:21 * obra nods +19:21 <obra> I was on a plane and was trying to see if MX::Compile was at the point where I could try trivial tests +19:22 <nothingmuch> ah +19:22 <nothingmuch> so the answer is definitely maybe ;-) +19:22 <nothingmuch> i haven't been able to make time for it in the past week +19:23 <nothingmuch> if you guys hand me small, targetted test cases (just commit to it) of code that passes under plain Moose and should pass with MX::Compile i can probably do that stuff pretty quickly +19:23 <nothingmuch> but the biggest barrier MXC has right now is testing, in order for it to progress towards something production worthy it basically needs to pass the Moose test suite +19:23 <nothingmuch> except without the Moose test suite's assumptions +19:23 <nothingmuch> about state and module loading, and all that +19:24 <nothingmuch> and doing that is a much more daunting prospect than hacking on MXC itself +19:24 <obra> understood. the problem is that I still don't have a good sense of how to get it going, even manually +19:24 <nothingmuch> ah +19:24 <obra> none of the test files seem to show off what I need +19:24 <nothingmuch> i can walk you through thjat +19:25 <nothingmuch> the assumptions of the system are: +19:25 <nothingmuch> the class you are compiling is in its own .pm using standard moose sugar +19:25 <nothingmuch> there is one package in that file +19:26 <nothingmuch> the compiler object takes the metaclass and the .pm file as args +19:26 <nothingmuch> it serializes the metaclass to a .mopc file, and the generated code into a .pmc +19:26 <nothingmuch> the .pmc contains the original .pm verbatim +19:26 <nothingmuch> except that all the moose sugar does nothing +19:27 <nothingmuch> meta is overriden to lazy load .mopc +19:27 <nothingmuch> and the class is supposed to be usable without loading Moose at all +19:27 <obra> what is the point of containing the original pm verbatim? +19:27 <nothingmuch> the user code +19:28 <nothingmuch> could open and slurp and eval +19:28 <nothingmuch> but this is a little more flexible +19:28 <nothingmuch> basically any subroutines the user has written, global/lexical variable initialization, loading of assorted modules etc all must work +19:28 <obra> are you using the flexibility? +19:28 <obra> (open, slurp, eval sounds suspiciously like "do") +19:29 <nothingmuch> can't use do/require/etc because it will go to the .pmc +19:29 <nothingmuch> instead of the .pm +19:29 <nothingmuch> the flexibility is helpful because you get a lexical set if the code is compiled +19:29 <nothingmuch> for when you need to do trickery +19:29 <nothingmuch> see Moose/Object.pm +19:29 <obra> I didn't think 'do' had that logic. but ok :) +19:30 <obra> anyway +19:30 <obra> do go on +19:30 <nothingmuch> now that we have Devel::Declare that might prove even simpler +19:30 <nothingmuch> simply replacing has() etc to export the subs inline +19:30 <nothingmuch> and write the resulting buffers to a .pmc +19:30 <nothingmuch> but that's for Later™ +19:30 <obra> The fact that the TM shows up in my terminal scare me +19:30 <obra> but only a bit less than that you typed it ;) +19:30 <nothingmuch> utf8++ +19:31 <obra> ubuntu++ +19:31 <nothingmuch> most linuxes seem to get that refreshingly right +19:31 <nothingmuch> so, erm +19:31 <obra> yeah. it's pleasant. +19:31 <nothingmuch> mxcompile +19:31 <obra> anyway +19:31 <nothingmuch> that is a nice frontend to the compiler object +19:31 <obra> I guess "what do I need to do to try MX::Compile for prophet+sd?" +19:31 <nothingmuch> it can recurse through a directory of modules, or take a list of classes +19:31 <nothingmuch> for starters, role support +19:31 <nothingmuch> i know how to do it +19:31 <nothingmuch> but haven't yet +19:32 <nothingmuch> type constraint support is very primitive +19:32 <obra> is that essentially the same code sartak needs to write to give Mouse roles? +19:32 <nothingmuch> i don't know what that is but doesn't sound likely +19:32 <nothingmuch> in MXC moose has already done the role composition +19:32 <nothingmuch> i just need to figure where the data came from, load that file and realias the subs +19:33 <nothingmuch> (at bootstrap time) +19:33 <nothingmuch> no role composition per se +19:33 <nothingmuch> it's nice to make clear that MXC has two "levels" of awesome +19:33 <nothingmuch> so you can figure out what you can hope to achieve +19:34 <nothingmuch> 100% compiled everything means you don't load Moose or Class::MOP +19:34 <nothingmuch> until you need runtime reflection +19:34 <nothingmuch> no codegen at compile time +19:34 <nothingmuch> it should load as fast as hand written code +19:34 <nothingmuch> i've had it beating Object::Tiny in some benchmarks =) +19:35 <obra> oo +19:35 <nothingmuch> Moose::XS should aid in making MooseX::Compile's supported feature set easier +19:35 <nothingmuch> the less awesome level of awesome is just some classes +19:35 <nothingmuch> you don't pay for those classes' compilation (Role composition, etc) +19:35 <obra> (especially since for me perl -MMoose -e1 takes up 50% of "sd help"'s runtime +19:36 <obra> (.4s here) +19:36 <nothingmuch> 5.8.8/ +19:36 <nothingmuch> ? +19:36 <obra> yeah +19:36 <obra> "that's what's in the wild" +19:36 <nothingmuch> i'm just curious if it makes a dfif +19:36 * obra nods +19:36 <obra> I don't have my macbook right now or I'd test +19:36 <nothingmuch> trunk moose loads slower +19:36 <obra> how much slower? +19:36 <nothingmuch> but 5.10 loads faster +19:36 <nothingmuch> negligiably +19:36 <nothingmuch> i think like 10% +19:36 <obra> this was trunk moose as of friday +19:36 <nothingmuch> but we can fix that +19:36 <nothingmuch> ah +19:36 <obra> my tests aren't scientific. +19:36 <nothingmuch> trunk moose as of you sending me nytprofs +19:37 <nothingmuch> actually that's CPAN moose now +19:37 <obra> 0.35 - 0.45 +19:37 <nothingmuch> ouch +19:37 <nothingmuch> well, part of the problem is that it loads *EVERYTHING* +19:37 <nothingmuch> every type of meta method class, meta type constraint, the role system, etc +19:37 <nothingmuch> for a big app these probably will get loaded +19:38 <nothingmuch> but for a small app, especially if you load the various sub modules only as needed, you shouldn't pay for these +19:38 <nothingmuch> that's a trivial fix that perigrin started working on +19:38 <obra> yeah. I played with his branch and saw no change as of last night +19:39 <obra> so yeah, we're using roles. if roles aren't ready yet, I won't get far at all. +19:39 <obra> (Also, I do really appreciate all the work you're doing. That I'm not paying for, even ;) +19:39 <obra> Thank you. +19:39 <nothingmuch> i will try shaving Moose's own load time with a profile based approach +19:39 <obra> It's SO MUCH better than it was +19:39 <nothingmuch> well, everybody wins =) +19:39 <nothingmuch> a. you're a friend +19:40 <nothingmuch> b. part of my job is making Moose work well +19:40 <nothingmuch> c. your using Moose helps moose directly and indirectly +19:40 <nothingmuch> d. I LIKE TACOS +19:40 <nothingmuch> erm, i mean sushi +19:40 <nothingmuch> so no worries on that +19:41 <nothingmuch> so, long term goals: +19:41 <nothingmuch> App::SD etc has all the meta calculations already cached in .mopc and .pmc +19:41 <nothingmuch> moose is not loaded +19:41 <nothingmuch> all generated code is cached +19:41 <nothingmuch> at worst Moose::XS is loaded to install subs with newXS +19:41 <obra> that would be really cool +19:41 <nothingmuch> depending on which actually fairs better +19:42 <nothingmuch> that goal is realistic, but involves a lot of work +19:42 <nothingmuch> more realistic short term goals: +19:42 <obra> I started playing with try to dump the symbol table, etc +19:42 <nothingmuch> MooseX::Compile partly speeding up SD +19:42 <nothingmuch> we can incrementally improve on that +19:42 <obra> and found that DD::Streamer is a lot closer than anything has ever been, but it craps out around not being able to dump lvalue subs +19:43 <nothingmuch> Moose::XS replacing some code gen +19:43 <nothingmuch> yes, the initial approach was to to try and marshall Moose classes into DDS +19:43 <nothingmuch> but it wasn't stable enough +19:43 <nothingmuch> and also there's the problem of imports +19:43 <nothingmuch> you must serialize the whole table at once +19:43 <nothingmuch> or manage an intricate web of inter dependencies +19:43 * obra nods +19:44 <nothingmuch> i sort of work around that by making all the require()/use() statements stay verbatim +19:44 <nothingmuch> also it doesn't handle xsubs +19:44 <obra> how hard would it be to get moose's codegen to write out source code instead of blowing subs into memory? +19:44 <nothingmuch> so there's guesswork for where ::bootstrap was called +19:44 <nothingmuch> i was just getting to that = +19:44 <nothingmuch> =) +19:44 <nothingmuch> pretty trivial +19:44 <obra> heh +19:44 <nothingmuch> just grunt work +19:44 <obra> is that a more viable approach? +19:44 <nothingmuch> it's one of the limiting parts of MooseX::Compile +19:45 <nothingmuch> if we clean up that code it will be easier to add support for more features +19:45 <nothingmuch> but it's not a huge hurdle since it's a very contained problem +19:45 <nothingmuch> it doesn't directly affect the design of MXC +19:45 <obra> is this stuff written down anywhere other than this buffer? +19:45 <nothingmuch> i don't think so +19:46 <obra> where should it get pasted? +19:46 <nothingmuch> good question =) +19:46 <nothingmuch> i think #moose-dev is pretty aware +19:46 <obra> is there a moose wiki? +19:46 <nothingmuch> but documenting is good for people to help out +19:46 <nothingmuch> no, there should be +19:46 <obra> yeah. but the goal is to turn it into written docs. +19:46 <obra> ok. for now, it should end up in MooseX-Compile/doc/design +19:46 <nothingmuch> sounds good +19:46 <obra> . o O { Thank god I don't have a moose commit bit } +19:47 <nothingmuch> though most of this affects moose itself though +19:47 * obra nods +19:47 <obra> Moose/doc/moosex-compile, then diff --git a/inc/CheckAuthorDeps.pm b/inc/CheckAuthorDeps.pm new file mode 100644 index 0000000..69f2dde --- /dev/null +++ b/inc/CheckAuthorDeps.pm @@ -0,0 +1,52 @@ +use strict; +use warnings; +package inc::CheckAuthorDeps; + +# our goal is to verify that the declared authordeps already reflect +# everything in configure + runtime prerequisites -- otherwise, we won't be +# able to bootstrap our built Moose for the purposes of running +# author/docGenerator.pl + +use Moose; +with 'Dist::Zilla::Role::AfterBuild'; + +sub after_build +{ + my $self = shift; + + # get our authordeps + require Dist::Zilla::Util::AuthorDeps; + Dist::Zilla::Util::AuthorDeps->VERSION(5.021); + + require CPAN::Meta::Requirements; + my $authordeps = CPAN::Meta::Requirements->new; + $authordeps->add_string_requirement(%$_) + foreach @{ Dist::Zilla::Util::AuthorDeps::extract_author_deps('.') }; + + # get our prereqs + my $prereqs = $self->zilla->prereqs; + + # merge prereqs into authordeps + my $merged_prereqs = CPAN::Meta::Requirements->new; + $merged_prereqs->add_requirements($authordeps); + $merged_prereqs->add_requirements($prereqs->requirements_for('configure', 'requires')); + $merged_prereqs->add_requirements($prereqs->requirements_for('runtime', 'requires')); + + # remove some false positives we know we already have fulfilled + $merged_prereqs->clear_requirement('ExtUtils::MakeMaker'); + $merged_prereqs->clear_requirement('Dist::CheckConflicts'); + + # the merged set should not be different than the original authordeps. + require Test::Deep; + my ($ok, $stack) = Test::Deep::cmp_details( + $authordeps->as_string_hash, + Test::Deep::superhashof($merged_prereqs->as_string_hash), + ); + + return if $ok; + + $self->log_fatal('authordeps does not have all prereqs found in configure, runtime prereqs: ' + . Test::Deep::deep_diag($stack)); +} + +1; diff --git a/inc/CheckDelta.pm b/inc/CheckDelta.pm new file mode 100644 index 0000000..d4ef142 --- /dev/null +++ b/inc/CheckDelta.pm @@ -0,0 +1,18 @@ +package inc::CheckDelta; +use Moose; + +with 'Dist::Zilla::Role::AfterBuild'; + +sub after_build { + my $self = shift; + + return unless $ENV{DZIL_RELEASING}; + + my ($delta) = grep { $_->name eq 'lib/Moose/Manual/Delta.pod' } + @{ $self->zilla->files }; + + die "Moose::Manual::Delta still contains \$NEXT" + if $delta->content =~ /\$NEXT/; +} + +1; diff --git a/inc/CheckReleaseType.pm b/inc/CheckReleaseType.pm new file mode 100644 index 0000000..6e79958 --- /dev/null +++ b/inc/CheckReleaseType.pm @@ -0,0 +1,37 @@ +package inc::CheckReleaseType; +use Moose; +with 'Dist::Zilla::Role::BeforeRelease'; + +# this is so I don't accidentally release 2.x<odd>xx without the --trial +# option, which has very nearly happened a few times. + +sub before_release +{ + my $self = shift; + my $version = $self->zilla->version; + + $version =~ m/^\d\.\d{4}$/ + or $self->log_fatal("version $version doesn't seem to conform to the normal specification!"); + + my $digit = substr($version, 3, 1); + if ($self->zilla->is_trial) + { + $digit % 2 == 1 + or $self->log_fatal('-TRIAL releases must be numbered 2.x{ODD}xx!'); + } + else + { + $digit % 2 == 0 + or $self->log_fatal('stable releases must be numbered 2.x{EVEN}xx!'); + + # Moose::Manual::Support says: + # 2.x{EVEN}00 must be January, April, July, October only. + if (substr($version, -2, 2) eq '00') + { + # month is 0..11 + my $month = (gmtime(time))[4]; + $month % 3 == 0 + or $self->log_fatal('2.x{EVEN}00 releases can only occur in January, April, July or October!'); + } + } +} diff --git a/inc/Clean.pm b/inc/Clean.pm new file mode 100644 index 0000000..a2a5563 --- /dev/null +++ b/inc/Clean.pm @@ -0,0 +1,50 @@ +package inc::Clean; +use Moose; + +with 'Dist::Zilla::Role::BeforeBuild', + 'Dist::Zilla::Role::AfterBuild'; +use Path::Tiny; +use File::pushd 'pushd'; +use Config; + +sub before_build { shift->_clean('.') } + +sub after_build { + my ($self, $opts) = @_; + + $self->_clean($opts->{build_root}); + + my $iter = path($opts->{build_root})->iterator({ recurse => 1 }); + my %found_files; + while (my $found_file = $iter->()) { + next if -d $found_file; + ++$found_files{ $found_file->relative($opts->{build_root}) }; + } + delete $found_files{$_->name} foreach @{ $self->zilla->files }; + + $self->log(join("\n", + "WARNING: Files were left behind in $opts->{build_root} that were not explicitly added:", + sort keys %found_files, + )) if keys %found_files; +} + +sub _clean { + my ($self, $build_dir) = @_; + + my $cwd = pushd $build_dir; + if (-e 'Makefile') { + + my $make = $Config{make} || 'make'; + + $self->log("Running $make distclean in $build_dir to clear out build cruft"); + my $pid = fork; + unless ($pid) { + close(STDIN); + close(STDOUT); + close(STDERR); + { exec("$^X Makefile.PL && $make distclean") } + die "couldn't exec: $!"; + } + waitpid($pid, 0) if $pid; + } +} diff --git a/inc/ExtractInlineTests.pm b/inc/ExtractInlineTests.pm new file mode 100644 index 0000000..e2cda0a --- /dev/null +++ b/inc/ExtractInlineTests.pm @@ -0,0 +1,58 @@ +package inc::ExtractInlineTests; + +use Moose; + +with 'Dist::Zilla::Role::FileGatherer'; + +use File::Find::Rule; +use inc::MyInline; +use Test::Inline; + +sub gather_files { + my $self = shift; + my $arg = shift; + + my $inline = Test::Inline->new( + verbose => 0, + ExtractHandler => 'My::Extract', + ContentHandler => 'My::Content', + OutputHandler => My::Output->new($self), + ); + + for my $pod ( + File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) { + $inline->add($pod); + } + + $inline->save; +} + +{ + package My::Output; + + sub new { + my $class = shift; + my $dzil = shift; + + return bless { dzil => $dzil }, $class; + } + + sub write { + my $self = shift; + my $name = shift; + my $content = shift; + + $name =~ s/^moose_cookbook_//; + + $self->{dzil}->add_file( + Dist::Zilla::File::InMemory->new( + name => "t/recipes/$name", + content => $content, + ) + ); + + return 1; + } +} + +1; diff --git a/inc/GenerateDocs.pm b/inc/GenerateDocs.pm new file mode 100644 index 0000000..27d4cf4 --- /dev/null +++ b/inc/GenerateDocs.pm @@ -0,0 +1,57 @@ +package inc::GenerateDocs; + +use Moose; +with 'Dist::Zilla::Role::FileGatherer', + 'Dist::Zilla::Role::AfterBuild', + 'Dist::Zilla::Role::FileInjector'; +use IPC::System::Simple qw(capturex); +use File::pushd; +use Path::Tiny; +use List::Util 'first'; + +my $filename = path(qw(lib Moose Manual Exceptions Manifest.pod)); + +sub gather_files { + my ($self, $arg) = @_; + + $self->add_file(Dist::Zilla::File::InMemory->new( + name => $filename->stringify, + # more to fill in later + content => <<'END_POD', +# PODNAME: Moose::Manual::Exceptions::Manifest +# ABSTRACT: Moose's Exception Types + +__END__ + +=for comment insert generated content here +END_POD + )); +} + +sub after_build { + my ($self, $opts) = @_; + my $build_dir = $opts->{build_root}; + + my $wd = File::pushd::pushd($build_dir); + unless ( -d 'blib' ) { + my @builders = @{ $self->zilla->plugins_with( -BuildRunner ) }; + die "no BuildRunner plugins specified" unless @builders; + $_->build for @builders; + die "no blib; failed to build properly?" unless -d 'blib'; + } + + # this must be run as a separate process because we need to use the new + # Moose we just generated, in order to introspect all the exception classes + $self->log('running author/docGenerator.pl...'); + my $text = capturex($^X, "author/docGenerator.pl"); + + my $file_obj = first { $_->name eq $filename } @{$self->zilla->files}; + + my $content = $file_obj->content; + my $pos = index($content, "\n\n=for comment insert generated content here"); + $file_obj->content(substr($content, 0, $pos) . "\n\n" . $text . substr($content, $pos, -1)); + + $filename->spew_raw($file_obj->encoded_content); +} + +1; diff --git a/inc/GitUpToDate.pm b/inc/GitUpToDate.pm new file mode 100644 index 0000000..b688d8a --- /dev/null +++ b/inc/GitUpToDate.pm @@ -0,0 +1,52 @@ +package inc::GitUpToDate; +use Moose; + +with 'Dist::Zilla::Role::BeforeBuild'; + +sub git { + if (wantarray) { + chomp(my @ret = qx{git $_[0]}); + return @ret; + } + else { + chomp(my $ret = qx{git $_[0]}); + return $ret; + } +} + +sub before_build { + my $self = shift; + + return unless $ENV{DZIL_RELEASING}; + + my $branch = git "symbolic-ref HEAD"; + die "Could not get the current branch" + unless $branch; + + $branch =~ s{refs/heads/}{}; + + $self->log("Ensuring branch $branch is up to date"); + + git "fetch origin"; + my $origin = git "rev-parse origin/$branch"; + my $head = git "rev-parse HEAD"; + + die "Branch $branch is not up to date (origin: $origin, HEAD: $head)" + if $origin ne $head; + + + # now also check that HEAD is current with the release branch + # that is, that the release branch is an ancestor commit of HEAD. + my $release_branch = ($self->zilla->plugin_named('Git::CheckFor::CorrectBranch')->release_branch)[0]; + foreach my $remote ('origin/', '') + { + my $release_commit = git "rev-parse ${remote}$release_branch"; + my $common_ancestor = git "merge-base $head $release_commit"; + + die "Branch $branch does not contain all commits from the current release branch ", + "(common ancestor for ${remote}$release_branch: $common_ancestor)" + if $common_ancestor ne $release_commit; + } +} + +1; diff --git a/inc/MMHelper.pm b/inc/MMHelper.pm new file mode 100644 index 0000000..7e340b9 --- /dev/null +++ b/inc/MMHelper.pm @@ -0,0 +1,79 @@ +package MMHelper; + +use strict; +use warnings; + +use Config; + +sub ccflags_dyn { + my $is_dev = shift; + + my $ccflags = q<( $Config::Config{ccflags} || '' ) . ' -I.'>; + if ($is_dev and ($Config{cc} !~ /^cl\b/i)) { + $ccflags .= q< . ' -Wall -Wdeclaration-after-statement'>; + } + + return $ccflags; +} + +sub ccflags_static { + my $is_dev = shift; + + return eval(ccflags_dyn($is_dev)); +} + +sub mm_args { + my ( @object, %xs ); + + for my $xs ( glob "xs/*.xs" ) { + ( my $c = $xs ) =~ s/\.xs$/.c/i; + ( my $o = $xs ) =~ s/\.xs$/\$(OBJ_EXT)/i; + + $xs{$xs} = $c; + push @object, $o; + } + + for my $c ( glob "*.c" ) { + ( my $o = $c ) =~ s/\.c$/\$(OBJ_EXT)/i; + push @object, $o; + } + + return ( + clean => { FILES => join( q{ }, @object ) }, + OBJECT => join( q{ }, @object ), + XS => \%xs, + ); +} + +sub my_package_subs { + return <<'EOP'; +{ +package MY; + +use Config; + +sub const_cccmd { + my $ret = shift->SUPER::const_cccmd(@_); + return q{} unless $ret; + + if ($Config{cc} =~ /^cl\b/i) { + warn 'you are using MSVC... we may not have gotten some options quite right.'; + $ret .= ' /Fo$@'; + } + else { + $ret .= ' -o $@'; + } + + return $ret; +} + +sub postamble { + return <<'EOF'; +$(OBJECT) : mop.h +EOF +} +} +EOP +} + +1; diff --git a/inc/MakeMaker.pm b/inc/MakeMaker.pm new file mode 100644 index 0000000..cd034ff --- /dev/null +++ b/inc/MakeMaker.pm @@ -0,0 +1,96 @@ +package inc::MakeMaker; + +use Moose; + +use lib 'inc'; + +use MMHelper; + +extends 'Dist::Zilla::Plugin::MakeMaker::Awesome'; + +override _build_MakeFile_PL_template => sub { + my $self = shift; + + my $tmpl = super(); + my $assert_compiler = <<'ASSERT_COMPILER'; +# Secondary compile testing via ExtUtils::CBuilder +sub can_xs { + # Do we have the configure_requires checker? + unless (eval 'require ExtUtils::CBuilder; ExtUtils::CBuilder->VERSION(0.27); 1') { + # They don't obey configure_requires, so it is + # someone old and delicate. Try to avoid hurting + # them by falling back to an older simpler test. + return can_cc(); + } + + return ExtUtils::CBuilder->new( quiet => 1 )->have_compiler; +} + +# can we locate a (the) C compiler +sub can_cc { + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# check if we can run some command +sub can_run { + my ($cmd) = @_; + + return $cmd if -x $cmd; + if (my $found_cmd = MM->maybe_command($cmd)) { + return $found_cmd; + } + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + next if $dir eq ''; + my $abs = File::Spec->catfile($dir, $cmd); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +die 'This distribution requires a working compiler' unless can_xs(); + +ASSERT_COMPILER + + # splice in our stuff after the preamble bits + # TODO - MMA ought to make this easier. + $tmpl =~ m/use warnings;\n\n/g; + $tmpl = substr($tmpl, 0, pos($tmpl)) . $assert_compiler . substr($tmpl, pos($tmpl)); + + + # TODO: splice this in using 'around _build_WriteMakefile_args' + my $ccflags = MMHelper::ccflags_dyn(); + $tmpl =~ s/^(WriteMakefile\()/\$WriteMakefileArgs{CCFLAGS} = $ccflags;\n\n$1/m; + + return $tmpl . "\n\n" . MMHelper::my_package_subs(); +}; + +override _build_WriteMakefile_args => sub { + my $self = shift; + + my $args = super(); + + return { + %{$args}, + MMHelper::mm_args(), + }; +}; + +override test => sub { + my $self = shift; + + local $ENV{PERL5LIB} = join ':', + grep {defined} @ENV{ 'PERL5LIB', 'DZIL_TEST_INC' }; + + super(); +}; + +1; diff --git a/inc/MyInline.pm b/inc/MyInline.pm new file mode 100644 index 0000000..e0697a6 --- /dev/null +++ b/inc/MyInline.pm @@ -0,0 +1,98 @@ +package MyInline; + +use strict; +use warnings; + +{ + package My::Extract; + + use parent 'Test::Inline::Extract'; + + use List::Util qw( first ); + + # This extracts the SYNOPSIS in addition to code specifically + # marked for testing + my $search = qr/ + (?:^|\n) # After the beginning of the string, or a newline + ( # ... start capturing + # EITHER + package\s+ # A package + [^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)* # ... with a name + \s*; # And a statement terminator + | # OR + \#\s*PODNAME:\s+ # A PODNAME comment + [^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)* # ... with a name + (?:\s+|$) # And a name terminator + | + =head1[ \t]+SYNOPSIS\n + .*? + (?=\n=) + | # OR + =for[ \t]+example[ \t]+begin\n # ... when we find a =for example begin + .*? # ... and keep capturing + \n=for[ \t]+example[ \t]+end\s*? # ... until the =for example end + (?:\n|$) # ... at the end of file or a newline + | # OR + =begin[ \t]+(?:test|testing)(?:-SETUP)? # ... when we find a =begin test or testing + .*? # ... and keep capturing + \n=end[ \t]+(?:test|testing)(?:-SETUP)? # ... until an =end tag + .*? + (?:\n|$) # ... at the end of file or a newline + ) # ... and stop capturing + /isx; + + sub _elements { + my $self = shift; + my @elements = (); + while ( $self->{source} =~ m/$search/go ) { + my $elt = $1; + + # A hack to turn the SYNOPSIS into something Test::Inline + # doesn't barf on + if ( $elt =~ s/=head1[ \t]+SYNOPSIS/=begin testing-SETUP\n\n{/ ) { + $elt .= "}\n\n=end testing-SETUP"; + } + + # It seems like search.cpan doesn't like a name with + # spaces after =begin. bleah, what a mess. + $elt =~ s/testing-SETUP/testing SETUP/g; + + push @elements, $elt; + } + + # If we have just one element it's a SYNOPSIS, so there's no + # tests. + return unless @elements > 2; + + if ( @elements && $self->{source} =~ /# PODNAME: (Moose::Cookbook\S+)(?:\s|$)/ ) { + foreach my $element (@elements) + { + $element = "package $1;" if $element =~ /# PODNAME: (Moose::Cookbook\S+)(?:\s+|$)/; + } + } + + if ( @elements && $self->{source} =~ /=head1 NAME\n\n(Moose::Cookbook\S+)/ ) { + unshift @elements, 'package ' . $1 . ';'; + } + + ( first {/^=/} @elements ) ? \@elements : ''; + } +} + +{ + package My::Content; + + use parent 'Test::Inline::Content::Default'; + + sub process { + my $self = shift; + + my $base = $self->SUPER::process(@_); + + $base =~ s/(\$\| = 1;)/use Test::Fatal;\n$1/; + + return $base; + } +} + +1; diff --git a/inc/SimpleAuthority.pm b/inc/SimpleAuthority.pm new file mode 100644 index 0000000..839571a --- /dev/null +++ b/inc/SimpleAuthority.pm @@ -0,0 +1,13 @@ +use strict; +use warnings; +package inc::SimpleAuthority; + +use Moose; +with 'Dist::Zilla::Role::MetaProvider'; + +sub metadata +{ + return +{ x_authority => 'cpan:STEVAN' }; +} + +1; diff --git a/inc/SimpleProvides.pm b/inc/SimpleProvides.pm new file mode 100644 index 0000000..3d768b1 --- /dev/null +++ b/inc/SimpleProvides.pm @@ -0,0 +1,34 @@ +use strict; +use warnings; +package inc::SimpleProvides; + +use Moose; +with 'Dist::Zilla::Role::MetaProvider', + 'Dist::Zilla::Role::FileFinderUser' => { + default_finders => [ ':InstallModules' ], # this is overridden in dist.ini! + }, +; + +sub metadata +{ + my $self = shift; + + my $version = $self->zilla->version; + + return +{ + provides => { + map { + # this is an awful hack and assumes ascii package names: + # please do not cargo-cult this code elsewhere. The proper + # thing to do is to crack open the file and read the pod name. + my $filename = $_->name; + (my $package = $filename) =~ s{[/\\]}{::}g; + $package =~ s/^lib:://; + $package =~ s/\.pod$//; + $package => { file => $filename, version => $version } + } @{$self->found_files}, + } + }; +} + +__PACKAGE__->meta->make_immutable; diff --git a/inc/TestRelease.pm b/inc/TestRelease.pm new file mode 100644 index 0000000..9d30a76 --- /dev/null +++ b/inc/TestRelease.pm @@ -0,0 +1,17 @@ +package inc::TestRelease; + +use Moose; + +extends 'Dist::Zilla::Plugin::TestRelease'; + +around before_release => sub { + my $orig = shift; + my $self = shift; + + local $ENV{MOOSE_TEST_MD} = 1 if not $self->zilla->is_trial; + local $ENV{AUTHOR_TESTING} = 1 if not $self->zilla->is_trial; + + $self->$orig(@_); +}; + +1; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm new file mode 100644 index 0000000..e55527d --- /dev/null +++ b/lib/Class/MOP.pm @@ -0,0 +1,1232 @@ +package Class::MOP; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use 5.008003; + +use MRO::Compat; +use Class::Load 0.07 (); +use Scalar::Util 'weaken', 'isweak', 'blessed'; +use Data::OptList; + +use Class::MOP::Mixin::AttributeCore; +use Class::MOP::Mixin::HasAttributes; +use Class::MOP::Mixin::HasMethods; +use Class::MOP::Mixin::HasOverloads; +use Class::MOP::Class; +use Class::MOP::Attribute; +use Class::MOP::Method; + +BEGIN { + *IS_RUNNING_ON_5_10 = ($] < 5.009_005) + ? sub () { 0 } + : sub () { 1 }; + + # this is either part of core or set up appropriately by MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; +} + +XSLoader::load( + 'Moose', + $VERSION, +); + +{ + # Metaclasses are singletons, so we cache them here. + # there is no need to worry about destruction though + # because they should die only when the program dies. + # After all, do package definitions even get reaped? + # Anonymous classes manage their own destruction. + my %METAS; + + sub get_all_metaclasses { %METAS } + sub get_all_metaclass_instances { values %METAS } + sub get_all_metaclass_names { keys %METAS } + sub get_metaclass_by_name { $METAS{$_[0]} } + sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] } + sub weaken_metaclass { weaken($METAS{$_[0]}) } + sub metaclass_is_weak { isweak($METAS{$_[0]}) } + sub does_metaclass_exist { exists $METAS{$_[0]} && defined $METAS{$_[0]} } + sub remove_metaclass_by_name { delete $METAS{$_[0]}; return } + + # This handles instances as well as class names + sub class_of { + return unless defined $_[0]; + my $class = blessed($_[0]) || $_[0]; + return $METAS{$class}; + } + + # NOTE: + # We only cache metaclasses, meaning instances of + # Class::MOP::Class. We do not cache instance of + # Class::MOP::Package or Class::MOP::Module. Mostly + # because I don't yet see a good reason to do so. +} + +sub load_class { + Class::MOP::Deprecated::deprecated( + message => 'Class::MOP::load_class is deprecated', + feature => 'Class::Load wrapper functions', + ); + require Class::Load; + goto &Class::Load::load_class; +} + +sub load_first_existing_class { + Class::MOP::Deprecated::deprecated( + message => 'Class::MOP::load_first_existing_class is deprecated', + feature => 'Class::Load wrapper functions', + ); + require Class::Load; + goto &Class::Load::load_first_existing_class; +} + +sub is_class_loaded { + Class::MOP::Deprecated::deprecated( + message => 'Class::MOP::is_class_loaded is deprecated', + feature => 'Class::Load wrapper functions', + ); + require Class::Load; + goto &Class::Load::is_class_loaded; +} + +sub _definition_context { + my %context; + @context{qw(package file line)} = caller(1); + + return ( + definition_context => \%context, + ); +} + +## ---------------------------------------------------------------------------- +## Setting up our environment ... +## ---------------------------------------------------------------------------- +## Class::MOP needs to have a few things in the global perl environment so +## that it can operate effectively. Those things are done here. +## ---------------------------------------------------------------------------- + +# ... nothing yet actually ;) + +## ---------------------------------------------------------------------------- +## Bootstrapping +## ---------------------------------------------------------------------------- +## The code below here is to bootstrap our MOP with itself. This is also +## sometimes called "tying the knot". By doing this, we make it much easier +## to extend the MOP through subclassing and such since now you can use the +## MOP itself to extend itself. +## +## Yes, I know, that's weird and insane, but it's a good thing, trust me :) +## ---------------------------------------------------------------------------- + +# We need to add in the meta-attributes here so that +# any subclass of Class::MOP::* will be able to +# inherit them using _construct_instance + +## -------------------------------------------------------- +## Class::MOP::Mixin::HasMethods + +Class::MOP::Mixin::HasMethods->meta->add_attribute( + Class::MOP::Attribute->new('_methods' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + '_method_map' => \&Class::MOP::Mixin::HasMethods::_method_map + }, + default => sub { {} }, + _definition_context(), + )) +); + +Class::MOP::Mixin::HasMethods->meta->add_attribute( + Class::MOP::Attribute->new('method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass + }, + default => 'Class::MOP::Method', + _definition_context(), + )) +); + +Class::MOP::Mixin::HasMethods->meta->add_attribute( + Class::MOP::Attribute->new('wrapped_method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass + }, + default => 'Class::MOP::Method::Wrapped', + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Mixin::HasAttributes + +Class::MOP::Mixin::HasAttributes->meta->add_attribute( + Class::MOP::Attribute->new('attributes' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map + }, + default => sub { {} }, + _definition_context(), + )) +); + +Class::MOP::Mixin::HasAttributes->meta->add_attribute( + Class::MOP::Attribute->new('attribute_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass + }, + default => 'Class::MOP::Attribute', + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Mixin::HasOverloads + +Class::MOP::Mixin::HasOverloads->meta->add_attribute( + Class::MOP::Attribute->new('_overload_map' => ( + reader => { + '_overload_map' => \&Class::MOP::Mixin::HasOverloads::_overload_map + }, + clearer => '_clear_overload_map', + default => sub { {} }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Package + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('package' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'name' => \&Class::MOP::Package::name + }, + _definition_context(), + )) +); + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('namespace' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'namespace' => \&Class::MOP::Package::namespace + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Module + +# NOTE: +# yeah this is kind of stretching things a bit, +# but truthfully the version should be an attribute +# of the Module, the weirdness comes from having to +# stick to Perl 5 convention and store it in the +# $VERSION package variable. Basically if you just +# squint at it, it will look how you want it to look. +# Either as a package variable, or as a attribute of +# the metaclass, isn't abstraction great :) + +Class::MOP::Module->meta->add_attribute( + Class::MOP::Attribute->new('version' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'version' => \&Class::MOP::Module::version + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +# NOTE: +# By following the same conventions as version here, +# we are opening up the possibility that people can +# use the $AUTHORITY in non-Class::MOP modules as +# well. + +Class::MOP::Module->meta->add_attribute( + Class::MOP::Attribute->new('authority' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'authority' => \&Class::MOP::Module::authority + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Class + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('superclasses' => ( + accessor => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'superclasses' => \&Class::MOP::Class::superclasses + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('instance_metaclass' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass + }, + default => 'Class::MOP::Instance', + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('immutable_trait' => ( + reader => { + 'immutable_trait' => \&Class::MOP::Class::immutable_trait + }, + default => "Class::MOP::Class::Immutable::Trait", + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('constructor_name' => ( + reader => { + 'constructor_name' => \&Class::MOP::Class::constructor_name, + }, + default => "new", + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('constructor_class' => ( + reader => { + 'constructor_class' => \&Class::MOP::Class::constructor_class, + }, + default => "Class::MOP::Method::Constructor", + _definition_context(), + )) +); + + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('destructor_class' => ( + reader => { + 'destructor_class' => \&Class::MOP::Class::destructor_class, + }, + _definition_context(), + )) +); + +# NOTE: +# we don't actually need to tie the knot with +# Class::MOP::Class here, it is actually handled +# within Class::MOP::Class itself in the +# _construct_class_instance method. + +## -------------------------------------------------------- +## Class::MOP::Mixin::AttributeCore +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('name' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'name' => \&Class::MOP::Mixin::AttributeCore::name + }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('accessor' => ( + reader => { 'accessor' => \&Class::MOP::Mixin::AttributeCore::accessor }, + predicate => { 'has_accessor' => \&Class::MOP::Mixin::AttributeCore::has_accessor }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('reader' => ( + reader => { 'reader' => \&Class::MOP::Mixin::AttributeCore::reader }, + predicate => { 'has_reader' => \&Class::MOP::Mixin::AttributeCore::has_reader }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('initializer' => ( + reader => { 'initializer' => \&Class::MOP::Mixin::AttributeCore::initializer }, + predicate => { 'has_initializer' => \&Class::MOP::Mixin::AttributeCore::has_initializer }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Mixin::AttributeCore::definition_context }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('writer' => ( + reader => { 'writer' => \&Class::MOP::Mixin::AttributeCore::writer }, + predicate => { 'has_writer' => \&Class::MOP::Mixin::AttributeCore::has_writer }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('predicate' => ( + reader => { 'predicate' => \&Class::MOP::Mixin::AttributeCore::predicate }, + predicate => { 'has_predicate' => \&Class::MOP::Mixin::AttributeCore::has_predicate }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('clearer' => ( + reader => { 'clearer' => \&Class::MOP::Mixin::AttributeCore::clearer }, + predicate => { 'has_clearer' => \&Class::MOP::Mixin::AttributeCore::has_clearer }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('builder' => ( + reader => { 'builder' => \&Class::MOP::Mixin::AttributeCore::builder }, + predicate => { 'has_builder' => \&Class::MOP::Mixin::AttributeCore::has_builder }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('init_arg' => ( + reader => { 'init_arg' => \&Class::MOP::Mixin::AttributeCore::init_arg }, + predicate => { 'has_init_arg' => \&Class::MOP::Mixin::AttributeCore::has_init_arg }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('default' => ( + # default has a custom 'reader' method ... + predicate => { 'has_default' => \&Class::MOP::Mixin::AttributeCore::has_default }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('insertion_order' => ( + reader => { 'insertion_order' => \&Class::MOP::Mixin::AttributeCore::insertion_order }, + writer => { '_set_insertion_order' => \&Class::MOP::Mixin::AttributeCore::_set_insertion_order }, + predicate => { 'has_insertion_order' => \&Class::MOP::Mixin::AttributeCore::has_insertion_order }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Attribute +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('associated_class' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'associated_class' => \&Class::MOP::Attribute::associated_class + }, + _definition_context(), + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('associated_methods' => ( + reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods }, + default => sub { [] }, + _definition_context(), + )) +); + +Class::MOP::Attribute->meta->add_method('clone' => sub { + my $self = shift; + $self->meta->clone_object($self, @_); +}); + +## -------------------------------------------------------- +## Class::MOP::Method +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('body' => ( + reader => { 'body' => \&Class::MOP::Method::body }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass' => ( + reader => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('package_name' => ( + reader => { 'package_name' => \&Class::MOP::Method::package_name }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('name' => ( + reader => { 'name' => \&Class::MOP::Method::name }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('original_method' => ( + reader => { 'original_method' => \&Class::MOP::Method::original_method }, + writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Wrapped + +# NOTE: +# the way this item is initialized, this +# really does not follow the standard +# practices of attributes, but we put +# it here for completeness +Class::MOP::Method::Wrapped->meta->add_attribute( + Class::MOP::Attribute->new('modifier_table' => ( + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Generated + +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('is_inline' => ( + reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, + default => 0, + _definition_context(), + )) +); + +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context }, + _definition_context(), + )) +); + + +## -------------------------------------------------------- +## Class::MOP::Method::Inlined + +Class::MOP::Method::Inlined->meta->add_attribute( + Class::MOP::Attribute->new('_expected_method_class' => ( + reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Accessor + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('attribute' => ( + reader => { + 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute + }, + _definition_context(), + )) +); + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('accessor_type' => ( + reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Constructor + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('options' => ( + reader => { + 'options' => \&Class::MOP::Method::Constructor::options + }, + default => sub { +{} }, + _definition_context(), + )) +); + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass' => ( + init_arg => "metaclass", # FIXME alias and rename + reader => { + 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass + }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Overload + +Class::MOP::Overload->meta->add_attribute( + Class::MOP::Attribute->new( + 'operator' => ( + reader => { 'operator' => \&Class::MOP::Overload::operator }, + required => 1, + _definition_context(), + ) + ) +); + +for my $attr (qw( method_name coderef coderef_package coderef_name method )) { + Class::MOP::Overload->meta->add_attribute( + Class::MOP::Attribute->new( + $attr => ( + reader => { $attr => Class::MOP::Overload->can($attr) }, + predicate => { + 'has_' + . $attr => Class::MOP::Overload->can( 'has_' . $attr ) + }, + _definition_context(), + ) + ) + ); +} + +Class::MOP::Overload->meta->add_attribute( + Class::MOP::Attribute->new( + 'associated_metaclass' => ( + reader => { + 'associated_metaclass' => + \&Class::MOP::Overload::associated_metaclass + }, + _definition_context(), + ) + ) +); + +## -------------------------------------------------------- +## Class::MOP::Instance + +# NOTE: +# these don't yet do much of anything, but are just +# included for completeness + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass', + reader => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('_class_name', + init_arg => undef, + reader => { _class_name => \&Class::MOP::Instance::_class_name }, + #lazy => 1, # not yet supported by Class::MOP but out our version does it anyway + #default => sub { $_[0]->associated_metaclass->name }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('attributes', + reader => { attributes => \&Class::MOP::Instance::get_all_attributes }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('slots', + reader => { slots => \&Class::MOP::Instance::slots }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('slot_hash', + reader => { slot_hash => \&Class::MOP::Instance::slot_hash }, + _definition_context(), + ), +); + +## -------------------------------------------------------- +## Class::MOP::Object + +# need to replace the meta method there with a real meta method object +Class::MOP::Object->meta->_add_meta_method('meta'); + +## -------------------------------------------------------- +## Class::MOP::Mixin + +# need to replace the meta method there with a real meta method object +Class::MOP::Mixin->meta->_add_meta_method('meta'); + +require Class::MOP::Deprecated unless our $no_deprecated; + +# we need the meta instance of the meta instance to be created now, in order +# for the constructor to be able to use it +Class::MOP::Instance->meta->get_meta_instance; + +# pretend the add_method never happened. it hasn't yet affected anything +undef Class::MOP::Instance->meta->{_package_cache_flag}; + +## -------------------------------------------------------- +## Now close all the Class::MOP::* classes + +# NOTE: we don't need to inline the accessors this only lengthens the compile +# time of the MOP, and gives us no actual benefits. + +$_->meta->make_immutable( + inline_constructor => 0, + constructor_name => "_new", + inline_accessors => 0, +) for qw/ + Class::MOP::Package + Class::MOP::Module + Class::MOP::Class + + Class::MOP::Attribute + Class::MOP::Method + Class::MOP::Instance + + Class::MOP::Object + + Class::MOP::Method::Generated + Class::MOP::Method::Inlined + + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor + Class::MOP::Method::Wrapped + + Class::MOP::Method::Meta + + Class::MOP::Overload +/; + +$_->meta->make_immutable( + inline_constructor => 0, + constructor_name => undef, + inline_accessors => 0, +) for qw/ + Class::MOP::Mixin + Class::MOP::Mixin::AttributeCore + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin::HasOverloads +/; + +1; + +# ABSTRACT: A Meta Object Protocol for Perl 5 + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP - A Meta Object Protocol for Perl 5 + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This module is a fully functioning meta object protocol for the +Perl 5 object system. It makes no attempt to change the behavior or +characteristics of the Perl 5 object system, only to create a +protocol for its manipulation and introspection. + +That said, it does attempt to create the tools for building a rich set +of extensions to the Perl 5 object system. Every attempt has been made +to abide by the spirit of the Perl 5 object system that we all know +and love. + +This documentation is sparse on conceptual details. We suggest looking +at the items listed in the L<SEE ALSO> section for more +information. In particular the book "The Art of the Meta Object +Protocol" was very influential in the development of this system. + +=head2 What is a Meta Object Protocol? + +A meta object protocol is an API to an object system. + +To be more specific, it abstracts the components of an object system +(classes, object, methods, object attributes, etc.). These +abstractions can then be used to inspect and manipulate the object +system which they describe. + +It can be said that there are two MOPs for any object system; the +implicit MOP and the explicit MOP. The implicit MOP handles things +like method dispatch or inheritance, which happen automatically as +part of how the object system works. The explicit MOP typically +handles the introspection/reflection features of the object system. + +All object systems have implicit MOPs. Without one, they would not +work. Explicit MOPs are much less common, and depending on the +language can vary from restrictive (Reflection in Java or C#) to wide +open (CLOS is a perfect example). + +=head2 Yet Another Class Builder! Why? + +This is B<not> a class builder so much as a I<class builder +B<builder>>. The intent is that an end user will not use this module +directly, but instead this module is used by module authors to build +extensions and features onto the Perl 5 object system. + +This system is used by L<Moose>, which supplies a powerful class +builder system built entirely on top of C<Class::MOP>. + +=head2 Who is this module for? + +This module is for anyone who has ever created or wanted to create a +module for the Class:: namespace. The tools which this module provides +make doing complex Perl 5 wizardry simpler, by removing such barriers +as the need to hack symbol tables, or understand the fine details of +method dispatch. + +=head2 What changes do I have to make to use this module? + +This module was designed to be as unobtrusive as possible. Many of its +features are accessible without B<any> change to your existing +code. It is meant to be a complement to your existing code and not an +intrusion on your code base. Unlike many other B<Class::> modules, +this module B<does not> require you subclass it, or even that you +C<use> it in within your module's package. + +The only features which require additions to your code are the +attribute handling and instance construction features, and these are +both completely optional features. The only reason for this is because +Perl 5's object system does not actually have these features built +in. More information about this feature can be found below. + +=head2 About Performance + +It is a common misconception that explicit MOPs are a performance hit. +This is not a universal truth, it is a side-effect of some specific +implementations. For instance, using Java reflection is slow because +the JVM cannot take advantage of any compiler optimizations, and the +JVM has to deal with much more runtime type information as well. + +Reflection in C# is marginally better as it was designed into the +language and runtime (the CLR). In contrast, CLOS (the Common Lisp +Object System) was built to support an explicit MOP, and so +performance is tuned for it. + +This library in particular does its absolute best to avoid putting +B<any> drain at all upon your code's performance. In fact, by itself +it does nothing to affect your existing code. So you only pay for what +you actually use. + +=head2 About Metaclass compatibility + +This module makes sure that all metaclasses created are both upwards +and downwards compatible. The topic of metaclass compatibility is +highly esoteric and is something only encountered when doing deep and +involved metaclass hacking. There are two basic kinds of metaclass +incompatibility; upwards and downwards. + +Upwards metaclass compatibility means that the metaclass of a +given class is either the same as (or a subclass of) all of the +metaclasses of the class's ancestors. + +Downward metaclass compatibility means that the metaclasses of a +given class's ancestors are all the same as (or a subclass of) that +class's metaclass. + +Here is a diagram showing a set of two classes (C<A> and C<B>) and +two metaclasses (C<Meta::A> and C<Meta::B>) which have correct +metaclass compatibility both upwards and downwards. + + +---------+ +---------+ + | Meta::A |<----| Meta::B | <....... (instance of ) + +---------+ +---------+ <------- (inherits from) + ^ ^ + : : + +---------+ +---------+ + | A |<----| B | + +---------+ +---------+ + +In actuality, I<all> of a class's metaclasses must be compatible, +not just the class metaclass. That includes the instance, attribute, +and method metaclasses, as well as the constructor and destructor +classes. + +C<Class::MOP> will attempt to fix some simple types of +incompatibilities. If all the metaclasses for the parent class are +I<subclasses> of the child's metaclasses then we can simply replace +the child's metaclasses with the parent's. In addition, if the child +is missing a metaclass that the parent has, we can also just make the +child use the parent's metaclass. + +As I said this is a highly esoteric topic and one you will only run +into if you do a lot of subclassing of L<Class::MOP::Class>. If you +are interested in why this is an issue see the paper I<Uniform and +safe metaclass composition> linked to in the L<SEE ALSO> section of +this document. + +=head2 Using custom metaclasses + +Always use the L<metaclass> pragma when using a custom metaclass, this +will ensure the proper initialization order and not accidentally +create an incorrect type of metaclass for you. This is a very rare +problem, and one which can only occur if you are doing deep metaclass +programming. So in other words, don't worry about it. + +Note that if you're using L<Moose> we encourage you to I<not> use the +L<metaclass> pragma, and instead use L<Moose::Util::MetaRole> to apply +roles to a class's metaclasses. This topic is covered at length in +various L<Moose::Cookbook> recipes. + +=head1 PROTOCOLS + +The meta-object protocol is divided into 4 main sub-protocols: + +=head2 The Class protocol + +This provides a means of manipulating and introspecting a Perl 5 +class. It handles symbol table hacking for you, and provides a rich +set of methods that go beyond simple package introspection. + +See L<Class::MOP::Class> for more details. + +=head2 The Attribute protocol + +This provides a consistent representation for an attribute of a Perl 5 +class. Since there are so many ways to create and handle attributes in +Perl 5 OO, the Attribute protocol provide as much of a unified +approach as possible. Of course, you are always free to extend this +protocol by subclassing the appropriate classes. + +See L<Class::MOP::Attribute> for more details. + +=head2 The Method protocol + +This provides a means of manipulating and introspecting methods in the +Perl 5 object system. As with attributes, there are many ways to +approach this topic, so we try to keep it pretty basic, while still +making it possible to extend the system in many ways. + +See L<Class::MOP::Method> for more details. + +=head2 The Instance protocol + +This provides a layer of abstraction for creating object instances. +Since the other layers use this protocol, it is relatively easy to +change the type of your instances from the default hash reference to +some other type of reference. Several examples are provided in the +F<examples/> directory included in this distribution. + +See L<Class::MOP::Instance> for more details. + +=head1 FUNCTIONS + +Note that this module does not export any constants or functions. + +=head2 Utility functions + +Note that these are all called as B<functions, not methods>. + +=over 4 + +=item B<Class::MOP::get_code_info($code)> + +This function returns two values, the name of the package the C<$code> +is from and the name of the C<$code> itself. This is used by several +elements of the MOP to determine where a given C<$code> reference is +from. + +=item B<Class::MOP::class_of($instance_or_class_name)> + +This will return the metaclass of the given instance or class name. If the +class lacks a metaclass, no metaclass will be initialized, and C<undef> will be +returned. + +You should almost certainly be using +L<C<Moose::Util::find_meta>|Moose::Util/find_meta> instead. + +=back + +=head2 Metaclass cache functions + +C<Class::MOP> holds a cache of metaclasses. The following are functions +(B<not methods>) which can be used to access that cache. It is not +recommended that you mess with these. Bad things could happen, but if +you are brave and willing to risk it: go for it! + +=over 4 + +=item B<Class::MOP::get_all_metaclasses> + +This will return a hash of all the metaclass instances that have +been cached by L<Class::MOP::Class>, keyed by the package name. + +=item B<Class::MOP::get_all_metaclass_instances> + +This will return a list of all the metaclass instances that have +been cached by L<Class::MOP::Class>. + +=item B<Class::MOP::get_all_metaclass_names> + +This will return a list of all the metaclass names that have +been cached by L<Class::MOP::Class>. + +=item B<Class::MOP::get_metaclass_by_name($name)> + +This will return a cached L<Class::MOP::Class> instance, or nothing +if no metaclass exists with that C<$name>. + +=item B<Class::MOP::store_metaclass_by_name($name, $meta)> + +This will store a metaclass in the cache at the supplied C<$key>. + +=item B<Class::MOP::weaken_metaclass($name)> + +In rare cases (e.g. anonymous metaclasses) it is desirable to +store a weakened reference in the metaclass cache. This +function will weaken the reference to the metaclass stored +in C<$name>. + +=item B<Class::MOP::metaclass_is_weak($name)> + +Returns true if the metaclass for C<$name> has been weakened +(via C<weaken_metaclass>). + +=item B<Class::MOP::does_metaclass_exist($name)> + +This will return true of there exists a metaclass stored in the +C<$name> key, and return false otherwise. + +=item B<Class::MOP::remove_metaclass_by_name($name)> + +This will remove the metaclass stored in the C<$name> key. + +=back + +Some utility functions (such as C<Class::MOP::load_class>) that were +previously defined in C<Class::MOP> regarding loading of classes have been +extracted to L<Class::Load>. Please see L<Class::Load> for documentation. + +=head1 SEE ALSO + +=head2 Books + +There are very few books out on Meta Object Protocols and Metaclasses +because it is such an esoteric topic. The following books are really +the only ones I have found. If you know of any more, B<I<please>> +email me and let me know, I would love to hear about them. + +=over 4 + +=item I<The Art of the Meta Object Protocol> + +=item I<Advances in Object-Oriented Metalevel Architecture and Reflection> + +=item I<Putting MetaClasses to Work> + +=item I<Smalltalk: The Language> + +=back + +=head2 Papers + +=over 4 + +=item "Uniform and safe metaclass composition" + +An excellent paper by the people who brought us the original Traits paper. +This paper is on how Traits can be used to do safe metaclass composition, +and offers an excellent introduction section which delves into the topic of +metaclass compatibility. + +L<http://scg.unibe.ch/archive/papers/Duca05ySafeMetaclassTrait.pdf> + +=item "Safe Metaclass Programming" + +This paper seems to precede the above paper, and propose a mix-in based +approach as opposed to the Traits based approach. Both papers have similar +information on the metaclass compatibility problem space. + +L<http://citeseer.ist.psu.edu/37617.html> + +=back + +=head2 Prior Art + +=over 4 + +=item The Perl 6 MetaModel work in the Pugs project + +=over 4 + +=item L<http://svn.openfoundry.org/pugs/misc/Perl-MetaModel/> + +=item L<http://github.com/perl6/p5-modules/tree/master/Perl6-ObjectSpace/> + +=back + +=back + +=head2 Articles + +=over 4 + +=item CPAN Module Review of Class::MOP + +L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html> + +=back + +=head1 SIMILAR MODULES + +As I have said above, this module is a class-builder-builder, so it is +not the same thing as modules like L<Class::Accessor> and +L<Class::MethodMaker>. That being said there are very few modules on CPAN +with similar goals to this module. The one I have found which is most +like this module is L<Class::Meta>, although its philosophy and the MOP it +creates are very different from this modules. + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. + +Please report any bugs to C<bug-class-mop@rt.cpan.org>, or through the +web interface at L<http://rt.cpan.org>. + +You can also discuss feature requests or possible bugs on the Moose +mailing list (moose@perl.org) or on IRC at +L<irc://irc.perl.org/#moose>. + +=head1 ACKNOWLEDGEMENTS + +=over 4 + +=item Rob Kinyon + +Thanks to Rob for actually getting the development of this module kick-started. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm new file mode 100644 index 0000000..c5c4995 --- /dev/null +++ b/lib/Class/MOP/Attribute.pm @@ -0,0 +1,1100 @@ +package Class::MOP::Attribute; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Method::Accessor; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore'; + +# NOTE: (meta-circularity) +# This method will be replaced in the +# boostrap section of Class::MOP, by +# a new version which uses the +# &Class::MOP::Class::construct_instance +# method to build an attribute meta-object +# which itself is described with attribute +# meta-objects. +# - Ain't meta-circularity grand? :) +sub new { + my ( $class, @args ) = @_; + + unshift @args, "name" if @args % 2 == 1; + my %options = @args; + + my $name = $options{name}; + + (defined $name) + || $class->_throw_exception( MOPAttributeNewNeedsAttributeName => class => $class, + params => \%options + ); + + $options{init_arg} = $name + if not exists $options{init_arg}; + if(exists $options{builder}){ + $class->_throw_exception( BuilderMustBeAMethodName => class => $class, + params => \%options + ) + if ref $options{builder} || !(defined $options{builder}); + $class->_throw_exception( BothBuilderAndDefaultAreNotAllowed => class => $class, + params => \%options + ) + if exists $options{default}; + } else { + ($class->is_default_a_coderef(\%options)) + || $class->_throw_exception( ReferencesAreNotAllowedAsDefault => class => $class, + params => \%options, + attribute_name => $options{name} + ) + if exists $options{default} && ref $options{default}; + } + + if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) { + $class->_throw_exception( RequiredAttributeLacksInitialization => class => $class, + params => \%options + ); + } + + $class->_new(\%options); +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $options = @_ == 1 ? $_[0] : {@_}; + + bless { + 'name' => $options->{name}, + 'accessor' => $options->{accessor}, + 'reader' => $options->{reader}, + 'writer' => $options->{writer}, + 'predicate' => $options->{predicate}, + 'clearer' => $options->{clearer}, + 'builder' => $options->{builder}, + 'init_arg' => $options->{init_arg}, + exists $options->{default} + ? ('default' => $options->{default}) + : (), + 'initializer' => $options->{initializer}, + 'definition_context' => $options->{definition_context}, + # keep a weakened link to the + # class we are associated with + 'associated_class' => undef, + # and a list of the methods + # associated with this attr + 'associated_methods' => [], + # this let's us keep track of + # our order inside the associated + # class + 'insertion_order' => undef, + }, $class; +} + +# NOTE: +# this is a primitive (and kludgy) clone operation +# for now, it will be replaced in the Class::MOP +# bootstrap with a proper one, however we know +# that this one will work fine for now. +sub clone { + my $self = shift; + my %options = @_; + (blessed($self)) + || confess "Can only clone an instance"; + # this implementation is overwritten by the bootstrap process, + # so this exception will never trigger. If it ever does occur, + # it indicates a gigantic problem with the most internal parts + # of Moose, so we wouldn't want a Moose-based exception object anyway + + return bless { %{$self}, %options } => ref($self); +} + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->{'init_arg'}; + + # try to fetch the init arg from the %params ... + + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if(defined $init_arg and exists $params->{$init_arg}){ + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $params->{$init_arg}, + ); + } + elsif (exists $self->{'default'}) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $self->default($instance), + ); + } + elsif (defined( my $builder = $self->{'builder'})) { + if ($builder = $instance->can($builder)) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $instance->$builder, + ); + } + else { + $self->_throw_exception( BuilderMethodNotSupportedForAttribute => attribute => $self, + instance => $instance + ); + } + } +} + +sub _set_initial_slot_value { + my ($self, $meta_instance, $instance, $value) = @_; + + my $slot_name = $self->name; + + return $meta_instance->set_slot_value($instance, $slot_name, $value) + unless $self->has_initializer; + + my $callback = $self->_make_initializer_writer_callback( + $meta_instance, $instance, $slot_name + ); + + my $initializer = $self->initializer; + + # most things will just want to set a value, so make it first arg + $instance->$initializer($value, $callback, $self); +} + +sub _make_initializer_writer_callback { + my $self = shift; + my ($meta_instance, $instance, $slot_name) = @_; + + return sub { + $meta_instance->set_slot_value($instance, $slot_name, $_[0]); + }; +} + +sub get_read_method { + my $self = shift; + my $reader = $self->reader || $self->accessor; + # normal case ... + return $reader unless ref $reader; + # the HASH ref case + my ($name) = %$reader; + return $name; +} + +sub get_write_method { + my $self = shift; + my $writer = $self->writer || $self->accessor; + # normal case ... + return $writer unless ref $writer; + # the HASH ref case + my ($name) = %$writer; + return $name; +} + +sub get_read_method_ref { + my $self = shift; + if ((my $reader = $self->get_read_method) && $self->associated_class) { + return $self->associated_class->get_method($reader); + } + else { + my $code = sub { $self->get_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } + } +} + +sub get_write_method_ref { + my $self = shift; + if ((my $writer = $self->get_write_method) && $self->associated_class) { + return $self->associated_class->get_method($writer); + } + else { + my $code = sub { $self->set_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } + } +} + +# slots + +sub slots { (shift)->name } + +# class association + +sub attach_to_class { + my ($self, $class) = @_; + (blessed($class) && $class->isa('Class::MOP::Class')) + || $self->_throw_exception( AttachToClassNeedsAClassMOPClassInstanceOrASubclass => attribute => $self, + class => $class + ); + weaken($self->{'associated_class'} = $class); +} + +sub detach_from_class { + my $self = shift; + $self->{'associated_class'} = undef; +} + +# method association + +sub associate_method { + my ($self, $method) = @_; + push @{$self->{'associated_methods'}} => $method; +} + +## Slot management + +sub set_initial_value { + my ($self, $instance, $value) = @_; + $self->_set_initial_slot_value( + Class::MOP::Class->initialize(ref($instance))->get_meta_instance, + $instance, + $value + ); +} + +sub set_value { shift->set_raw_value(@_) } + +sub set_raw_value { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->set_slot_value($instance, $self->name, $value); +} + +sub _inline_set_value { + my $self = shift; + return $self->_inline_instance_set(@_) . ';'; +} + +sub _inline_instance_set { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_set_slot_value($instance, $self->name, $value); +} + +sub get_value { shift->get_raw_value(@_) } + +sub get_raw_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->get_slot_value($instance, $self->name); +} + +sub _inline_get_value { + my $self = shift; + return $self->_inline_instance_get(@_) . ';'; +} + +sub _inline_instance_get { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_get_slot_value($instance, $self->name); +} + +sub has_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->is_slot_initialized($instance, $self->name); +} + +sub _inline_has_value { + my $self = shift; + return $self->_inline_instance_has(@_) . ';'; +} + +sub _inline_instance_has { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_is_slot_initialized($instance, $self->name); +} + +sub clear_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->deinitialize_slot($instance, $self->name); +} + +sub _inline_clear_value { + my $self = shift; + return $self->_inline_instance_clear(@_) . ';'; +} + +sub _inline_instance_clear { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_deinitialize_slot($instance, $self->name); +} + +## load em up ... + +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } + +sub _process_accessors { + my ($self, $type, $accessor, $generate_as_inline_methods) = @_; + + my $method_ctx = { %{ $self->definition_context || {} } }; + + if (ref($accessor)) { + (ref($accessor) eq 'HASH') + || $self->_throw_exception( BadOptionFormat => attribute => $self, + option_value => $accessor, + option_name => $type + ); + + my ($name, $method) = %{$accessor}; + + $method_ctx->{description} = $self->_accessor_description($name, $type); + + $method = $self->accessor_metaclass->wrap( + $method, + attribute => $self, + package_name => $self->associated_class->name, + name => $name, + associated_metaclass => $self->associated_class, + definition_context => $method_ctx, + ); + $self->associate_method($method); + return ($name, $method); + } + else { + my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); + my $method; + try { + $method_ctx->{description} = $self->_accessor_description($accessor, $type); + + $method = $self->accessor_metaclass->new( + attribute => $self, + is_inline => $inline_me, + accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, + associated_metaclass => $self->associated_class, + definition_context => $method_ctx, + ); + } + catch { + $self->_throw_exception( CouldNotCreateMethod => attribute => $self, + option_value => $accessor, + option_name => $type, + error => $_ + ); + }; + $self->associate_method($method); + return ($accessor, $method); + } +} + +sub _accessor_description { + my $self = shift; + my ($name, $type) = @_; + + my $desc = "$type " . $self->associated_class->name . "::$name"; + if ( $name ne $self->name ) { + $desc .= " of attribute " . $self->name; + } + + return $desc; +} + +sub install_accessors { + my $self = shift; + my $inline = shift; + my $class = $self->associated_class; + + $class->add_method( + $self->_process_accessors('accessor' => $self->accessor(), $inline) + ) if $self->has_accessor(); + + $class->add_method( + $self->_process_accessors('reader' => $self->reader(), $inline) + ) if $self->has_reader(); + + $class->add_method( + $self->_process_accessors('writer' => $self->writer(), $inline) + ) if $self->has_writer(); + + $class->add_method( + $self->_process_accessors('predicate' => $self->predicate(), $inline) + ) if $self->has_predicate(); + + $class->add_method( + $self->_process_accessors('clearer' => $self->clearer(), $inline) + ) if $self->has_clearer(); + + return; +} + +{ + my $_remove_accessor = sub { + my ($accessor, $class) = @_; + if (ref($accessor) && ref($accessor) eq 'HASH') { + ($accessor) = keys %{$accessor}; + } + my $method = $class->get_method($accessor); + $class->remove_method($accessor) + if (ref($method) && $method->isa('Class::MOP::Method::Accessor')); + }; + + sub remove_accessors { + my $self = shift; + # TODO: + # we really need to make sure to remove from the + # associates methods here as well. But this is + # such a slimly used method, I am not worried + # about it right now. + $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor(); + $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader(); + $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer(); + $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate(); + $_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer(); + return; + } + +} + +1; + +# ABSTRACT: Attribute Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Attribute - Attribute Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + Class::MOP::Attribute->new( + foo => ( + accessor => 'foo', # dual purpose get/set accessor + predicate => 'has_foo', # predicate check for defined-ness + init_arg => '-foo', # class->new will look for a -foo key + default => 'BAR IS BAZ!' # if no -foo key is provided, use this + ) + ); + + Class::MOP::Attribute->new( + bar => ( + reader => 'bar', # getter + writer => 'set_bar', # setter + predicate => 'has_bar', # predicate check for defined-ness + init_arg => ':bar', # class->new will look for a :bar key + # no default value means it is undef + ) + ); + +=head1 DESCRIPTION + +The Attribute Protocol is almost entirely an invention of +C<Class::MOP>. Perl 5 does not have a consistent notion of +attributes. There are so many ways in which this is done, and very few +(if any) are easily discoverable by this module. + +With that said, this module attempts to inject some order into this +chaos, by introducing a consistent API which can be used to create +object attributes. + +=head1 METHODS + +=head2 Creation + +=over 4 + +=item B<< Class::MOP::Attribute->new($name, ?%options) >> + +An attribute must (at the very least), have a C<$name>. All other +C<%options> are added as key-value pairs. + +=over 8 + +=item * init_arg + +This is a string value representing the expected key in an +initialization hash. For instance, if we have an C<init_arg> value of +C<-foo>, then the following code will Just Work. + + MyClass->meta->new_object( -foo => 'Hello There' ); + +If an init_arg is not assigned, it will automatically use the +attribute's name. If C<init_arg> is explicitly set to C<undef>, the +attribute cannot be specified during initialization. + +=item * builder + +This provides the name of a method that will be called to initialize +the attribute. This method will be called on the object after it is +constructed. It is expected to return a valid value for the attribute. + +=item * default + +This can be used to provide an explicit default for initializing the +attribute. If the default you provide is a subroutine reference, then +this reference will be called I<as a method> on the object. + +If the value is a simple scalar (string or number), then it can be +just passed as is. However, if you wish to initialize it with a HASH +or ARRAY ref, then you need to wrap that inside a subroutine +reference: + + Class::MOP::Attribute->new( + 'foo' => ( + default => sub { [] }, + ) + ); + + # or ... + + Class::MOP::Attribute->new( + 'foo' => ( + default => sub { {} }, + ) + ); + +If you wish to initialize an attribute with a subroutine reference +itself, then you need to wrap that in a subroutine as well: + + Class::MOP::Attribute->new( + 'foo' => ( + default => sub { + sub { print "Hello World" } + }, + ) + ); + +And lastly, if the value of your attribute is dependent upon some +other aspect of the instance structure, then you can take advantage of +the fact that when the C<default> value is called as a method: + + Class::MOP::Attribute->new( + 'object_identity' => ( + default => sub { Scalar::Util::refaddr( $_[0] ) }, + ) + ); + +Note that there is no guarantee that attributes are initialized in any +particular order, so you cannot rely on the value of some other +attribute when generating the default. + +=item * initializer + +This option can be either a method name or a subroutine +reference. This method will be called when setting the attribute's +value in the constructor. Unlike C<default> and C<builder>, the +initializer is only called when a value is provided to the +constructor. The initializer allows you to munge this value during +object construction. + +The initializer is called as a method with three arguments. The first +is the value that was passed to the constructor. The second is a +subroutine reference that can be called to actually set the +attribute's value, and the last is the associated +C<Class::MOP::Attribute> object. + +This contrived example shows an initializer that sets the attribute to +twice the given value. + + Class::MOP::Attribute->new( + 'doubled' => ( + initializer => sub { + my ( $self, $value, $set, $attr ) = @_; + $set->( $value * 2 ); + }, + ) + ); + +Since an initializer can be a method name, you can easily make +attribute initialization use the writer: + + Class::MOP::Attribute->new( + 'some_attr' => ( + writer => 'some_attr', + initializer => 'some_attr', + ) + ); + +Your writer (actually, a wrapper around the writer, using +L<method modifications|Moose::Manual::MethodModifiers>) will need to examine +C<@_> and determine under which +context it is being called: + + around 'some_attr' => sub { + my $orig = shift; + my $self = shift; + # $value is not defined if being called as a reader + # $setter and $attr are only defined if being called as an initializer + my ($value, $setter, $attr) = @_; + + # the reader behaves normally + return $self->$orig if not @_; + + # mutate $value as desired + # $value = <something($value); + + # if called as an initializer, set the value and we're done + return $setter->($row) if $setter; + + # otherwise, call the real writer with the new value + $self->$orig($row); + }; + +=back + +The C<accessor>, C<reader>, C<writer>, C<predicate> and C<clearer> +options all accept the same parameters. You can provide the name of +the method, in which case an appropriate default method will be +generated for you. Or instead you can also provide hash reference +containing exactly one key (the method name) and one value. The value +should be a subroutine reference, which will be installed as the +method itself. + +=over 8 + +=item * accessor + +An C<accessor> is a standard Perl-style read/write accessor. It will +return the value of the attribute, and if a value is passed as an +argument, it will assign that value to the attribute. + +Note that C<undef> is a legitimate value, so this will work: + + $object->set_something(undef); + +=item * reader + +This is a basic read-only accessor. It returns the value of the +attribute. + +=item * writer + +This is a basic write accessor, it accepts a single argument, and +assigns that value to the attribute. + +Note that C<undef> is a legitimate value, so this will work: + + $object->set_something(undef); + +=item * predicate + +The predicate method returns a boolean indicating whether or not the +attribute has been explicitly set. + +Note that the predicate returns true even if the attribute was set to +a false value (C<0> or C<undef>). + +=item * clearer + +This method will uninitialize the attribute. After an attribute is +cleared, its C<predicate> will return false. + +=item * definition_context + +Mostly, this exists as a hook for the benefit of Moose. + +This option should be a hash reference containing several keys which +will be used when inlining the attribute's accessors. The keys should +include C<line>, the line number where the attribute was created, and +either C<file> or C<description>. + +This information will ultimately be used when eval'ing inlined +accessor code so that error messages report a useful line and file +name. + +=back + +=item B<< $attr->clone(%options) >> + +This clones the attribute. Any options you provide will override the +settings of the original attribute. You can change the name of the new +attribute by passing a C<name> key in C<%options>. + +=back + +=head2 Informational + +These are all basic read-only accessors for the values passed into +the constructor. + +=over 4 + +=item B<< $attr->name >> + +Returns the attribute's name. + +=item B<< $attr->accessor >> + +=item B<< $attr->reader >> + +=item B<< $attr->writer >> + +=item B<< $attr->predicate >> + +=item B<< $attr->clearer >> + +The C<accessor>, C<reader>, C<writer>, C<predicate>, and C<clearer> +methods all return exactly what was passed to the constructor, so it +can be either a string containing a method name, or a hash reference. + +=item B<< $attr->initializer >> + +Returns the initializer as passed to the constructor, so this may be +either a method name or a subroutine reference. + +=item B<< $attr->init_arg >> + +=item B<< $attr->is_default_a_coderef >> + +=item B<< $attr->builder >> + +=item B<< $attr->default($instance) >> + +The C<$instance> argument is optional. If you don't pass it, the +return value for this method is exactly what was passed to the +constructor, either a simple scalar or a subroutine reference. + +If you I<do> pass an C<$instance> and the default is a subroutine +reference, then the reference is called as a method on the +C<$instance> and the generated value is returned. + +=item B<< $attr->slots >> + +Return a list of slots required by the attribute. This is usually just +one, the name of the attribute. + +A slot is the name of the hash key used to store the attribute in an +object instance. + +=item B<< $attr->get_read_method >> + +=item B<< $attr->get_write_method >> + +Returns the name of a method suitable for reading or writing the value +of the attribute in the associated class. + +If an attribute is read- or write-only, then these methods can return +C<undef> as appropriate. + +=item B<< $attr->has_read_method >> + +=item B<< $attr->has_write_method >> + +This returns a boolean indicating whether the attribute has a I<named> +read or write method. + +=item B<< $attr->get_read_method_ref >> + +=item B<< $attr->get_write_method_ref >> + +Returns the subroutine reference of a method suitable for reading or +writing the attribute's value in the associated class. These methods +always return a subroutine reference, regardless of whether or not the +attribute is read- or write-only. + +=item B<< $attr->insertion_order >> + +If this attribute has been inserted into a class, this returns a zero +based index regarding the order of insertion. + +=back + +=head2 Informational predicates + +These are all basic predicate methods for the values passed into C<new>. + +=over 4 + +=item B<< $attr->has_accessor >> + +=item B<< $attr->has_reader >> + +=item B<< $attr->has_writer >> + +=item B<< $attr->has_predicate >> + +=item B<< $attr->has_clearer >> + +=item B<< $attr->has_initializer >> + +=item B<< $attr->has_init_arg >> + +This will be I<false> if the C<init_arg> was set to C<undef>. + +=item B<< $attr->has_default >> + +This will be I<false> if the C<default> was set to C<undef>, since +C<undef> is the default C<default> anyway. + +=item B<< $attr->has_builder >> + +=item B<< $attr->has_insertion_order >> + +This will be I<false> if this attribute has not be inserted into a class + +=back + +=head2 Value management + +These methods are basically "back doors" to the instance, and can be +used to bypass the regular accessors, but still stay within the MOP. + +These methods are not for general use, and should only be used if you +really know what you are doing. + +=over 4 + +=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> + +This method is used internally to initialize the attribute's slot in +the object C<$instance>. + +The C<$params> is a hash reference of the values passed to the object +constructor. + +It's unlikely that you'll need to call this method yourself. + +=item B<< $attr->set_value($instance, $value) >> + +Sets the value without going through the accessor. Note that this +works even with read-only attributes. + +=item B<< $attr->set_raw_value($instance, $value) >> + +Sets the value with no side effects such as a trigger. + +This doesn't actually apply to Class::MOP attributes, only to subclasses. + +=item B<< $attr->set_initial_value($instance, $value) >> + +Sets the value without going through the accessor. This method is only +called when the instance is first being initialized. + +=item B<< $attr->get_value($instance) >> + +Returns the value without going through the accessor. Note that this +works even with write-only accessors. + +=item B<< $attr->get_raw_value($instance) >> + +Returns the value without any side effects such as lazy attributes. + +Doesn't actually apply to Class::MOP attributes, only to subclasses. + +=item B<< $attr->has_value($instance) >> + +Return a boolean indicating whether the attribute has been set in +C<$instance>. This how the default C<predicate> method works. + +=item B<< $attr->clear_value($instance) >> + +This will clear the attribute's value in C<$instance>. This is what +the default C<clearer> calls. + +Note that this works even if the attribute does not have any +associated read, write or clear methods. + +=back + +=head2 Class association + +These methods allow you to manage the attributes association with +the class that contains it. These methods should not be used +lightly, nor are they very magical, they are mostly used internally +and by metaclass instances. + +=over 4 + +=item B<< $attr->associated_class >> + +This returns the L<Class::MOP::Class> with which this attribute is +associated, if any. + +=item B<< $attr->attach_to_class($metaclass) >> + +This method stores a weakened reference to the C<$metaclass> object +internally. + +This method does not remove the attribute from its old class, +nor does it create any accessors in the new class. + +It is probably best to use the L<Class::MOP::Class> C<add_attribute> +method instead. + +=item B<< $attr->detach_from_class >> + +This method removes the associate metaclass object from the attribute +it has one. + +This method does not remove the attribute itself from the class, or +remove its accessors. + +It is probably best to use the L<Class::MOP::Class> +C<remove_attribute> method instead. + +=back + +=head2 Attribute Accessor generation + +=over 4 + +=item B<< $attr->accessor_metaclass >> + +Accessor methods are generated using an accessor metaclass. By +default, this is L<Class::MOP::Method::Accessor>. This method returns +the name of the accessor metaclass that this attribute uses. + +=item B<< $attr->associate_method($method) >> + +This associates a L<Class::MOP::Method> object with the +attribute. Typically, this is called internally when an attribute +generates its accessors. + +=item B<< $attr->associated_methods >> + +This returns the list of methods which have been associated with the +attribute. + +=item B<< $attr->install_accessors >> + +This method generates and installs code the attributes various +accessors. It is typically called from the L<Class::MOP::Class> +C<add_attribute> method. + +=item B<< $attr->remove_accessors >> + +This method removes all of the accessors associated with the +attribute. + +This does not currently remove methods from the list returned by +C<associated_methods>. + +=item B<< $attr->inline_get >> + +=item B<< $attr->inline_set >> + +=item B<< $attr->inline_has >> + +=item B<< $attr->inline_clear >> + +These methods return a code snippet suitable for inlining the relevant +operation. They expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Attribute->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm new file mode 100644 index 0000000..c5e1bae --- /dev/null +++ b/lib/Class/MOP/Class.pm @@ -0,0 +1,2312 @@ +package Class::MOP::Class; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Instance; +use Class::MOP::Method::Wrapped; +use Class::MOP::Method::Accessor; +use Class::MOP::Method::Constructor; +use Class::MOP::MiniTrait; + +use Carp 'confess'; +use Module::Runtime 'use_package_optimistically'; +use Scalar::Util 'blessed'; +use Sub::Name 'subname'; +use Try::Tiny; +use List::Util 1.33 'all'; + +use parent 'Class::MOP::Module', + 'Class::MOP::Mixin::HasAttributes', + 'Class::MOP::Mixin::HasMethods', + 'Class::MOP::Mixin::HasOverloads'; + +# Creation + +sub initialize { + my $class = shift; + + my $package_name; + + if ( @_ % 2 ) { + $package_name = shift; + } else { + my %options = @_; + $package_name = $options{package}; + } + + ($package_name && !ref($package_name)) + || ($class||__PACKAGE__)->_throw_exception( InitializeTakesUnBlessedPackageName => package_name => $package_name ); + return Class::MOP::get_metaclass_by_name($package_name) + || $class->_construct_class_instance(package => $package_name, @_); +} + +sub reinitialize { + my ( $class, @args ) = @_; + unshift @args, "package" if @args % 2; + my %options = @args; + my $old_metaclass = blessed($options{package}) + ? $options{package} + : Class::MOP::get_metaclass_by_name($options{package}); + $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name) + if !exists $options{weaken} + && blessed($old_metaclass) + && $old_metaclass->isa('Class::MOP::Class'); + $old_metaclass->_remove_generated_metaobjects + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + my $new_metaclass = $class->SUPER::reinitialize(%options); + $new_metaclass->_restore_metaobjects_from($old_metaclass) + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + return $new_metaclass; +} + +# NOTE: (meta-circularity) +# this is a special form of _construct_instance +# (see below), which is used to construct class +# meta-object instances for any Class::MOP::* +# class. All other classes will use the more +# normal &construct_instance. +sub _construct_class_instance { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + my $package_name = $options->{package}; + (defined $package_name && $package_name) + || $class->_throw_exception("ConstructClassInstanceTakesPackageName"); + # NOTE: + # return the metaclass if we have it cached, + # and it is still defined (it has not been + # reaped by DESTROY yet, which can happen + # annoyingly enough during global destruction) + + if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) { + return $meta; + } + + $class + = ref $class + ? $class->_real_ref_name + : $class; + + # now create the metaclass + my $meta; + if ($class eq 'Class::MOP::Class') { + $meta = $class->_new($options); + } + else { + # NOTE: + # it is safe to use meta here because + # class will always be a subclass of + # Class::MOP::Class, which defines meta + $meta = $class->meta->_construct_instance($options) + } + + # and check the metaclass compatibility + $meta->_check_metaclass_compatibility(); + + Class::MOP::store_metaclass_by_name($package_name, $meta); + + # NOTE: + # we need to weaken any anon classes + # so that they can call DESTROY properly + Class::MOP::weaken_metaclass($package_name) if $options->{weaken}; + + $meta; +} + +sub _real_ref_name { + my $self = shift; + + # NOTE: we need to deal with the possibility of class immutability here, + # and then get the name of the class appropriately + return $self->is_immutable + ? $self->_get_mutable_metaclass_name() + : ref $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Package + 'package' => $options->{package}, + + # NOTE: + # since the following attributes will + # actually be loaded from the symbol + # table, and actually bypass the instance + # entirely, we can just leave these things + # listed here for reference, because they + # should not actually have a value associated + # with the slot. + 'namespace' => \undef, + 'methods' => {}, + + # inherited from Class::MOP::Module + 'version' => \undef, + 'authority' => \undef, + + # defined in Class::MOP::Class + 'superclasses' => \undef, + + 'attributes' => {}, + 'attribute_metaclass' => + ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), + 'method_metaclass' => + ( $options->{'method_metaclass'} || 'Class::MOP::Method' ), + 'wrapped_method_metaclass' => ( + $options->{'wrapped_method_metaclass'} + || 'Class::MOP::Method::Wrapped' + ), + 'instance_metaclass' => + ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ), + 'immutable_trait' => ( + $options->{'immutable_trait'} + || 'Class::MOP::Class::Immutable::Trait' + ), + 'constructor_name' => ( $options->{constructor_name} || 'new' ), + 'constructor_class' => ( + $options->{constructor_class} || 'Class::MOP::Method::Constructor' + ), + 'destructor_class' => $options->{destructor_class}, + }, $class; +} + +## Metaclass compatibility +{ + my %base_metaclass = ( + attribute_metaclass => 'Class::MOP::Attribute', + method_metaclass => 'Class::MOP::Method', + wrapped_method_metaclass => 'Class::MOP::Method::Wrapped', + instance_metaclass => 'Class::MOP::Instance', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => 'Class::MOP::Method::Destructor', + ); + + sub _base_metaclasses { %base_metaclass } +} + +sub _check_metaclass_compatibility { + my $self = shift; + + my @superclasses = $self->superclasses + or return; + + $self->_fix_metaclass_incompatibility(@superclasses); + + my %base_metaclass = $self->_base_metaclasses; + + # this is always okay ... + return + if ref($self) eq 'Class::MOP::Class' + && all { + my $meta = $self->$_; + !defined($meta) || $meta eq $base_metaclass{$_}; + } + keys %base_metaclass; + + for my $superclass (@superclasses) { + $self->_check_class_metaclass_compatibility($superclass); + } + + for my $metaclass_type ( keys %base_metaclass ) { + next unless defined $self->$metaclass_type; + for my $superclass (@superclasses) { + $self->_check_single_metaclass_compatibility( $metaclass_type, + $superclass ); + } + } +} + +sub _check_class_metaclass_compatibility { + my $self = shift; + my ( $superclass_name ) = @_; + + if (!$self->_class_metaclass_is_compatible($superclass_name)) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + + my $super_meta_type = $super_meta->_real_ref_name; + + $self->_throw_exception( IncompatibleMetaclassOfSuperclass => class_name => $self->name, + class_meta_type => ref( $self ), + superclass_name => $superclass_name, + superclass_meta_type => $super_meta_type + ); + } +} + +sub _class_metaclass_is_compatible { + my $self = shift; + my ( $superclass_name ) = @_; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) + || return 1; + + my $super_meta_name = $super_meta->_real_ref_name; + + return $self->_is_compatible_with($super_meta_name); +} + +sub _check_single_metaclass_compatibility { + my $self = shift; + my ( $metaclass_type, $superclass_name ) = @_; + + if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + + $self->_throw_exception( MetaclassTypeIncompatible => class_name => $self->name, + superclass_name => $superclass_name, + metaclass_type => $metaclass_type + ); + } +} + +sub _single_metaclass_is_compatible { + my $self = shift; + my ( $metaclass_type, $superclass_name ) = @_; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) + || return 1; + + # for instance, Moose::Meta::Class has a error_class attribute, but + # Class::MOP::Class doesn't - this shouldn't be an error + return 1 unless $super_meta->can($metaclass_type); + # for instance, Moose::Meta::Class has a destructor_class, but + # Class::MOP::Class doesn't - this shouldn't be an error + return 1 unless defined $super_meta->$metaclass_type; + # if metaclass is defined in superclass but not here, it's not compatible + # this is a really odd case + return 0 unless defined $self->$metaclass_type; + + return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type); +} + +sub _fix_metaclass_incompatibility { + my $self = shift; + my @supers = map { Class::MOP::Class->initialize($_) } @_; + + my $necessary = 0; + for my $super (@supers) { + $necessary = 1 + if $self->_can_fix_metaclass_incompatibility($super); + } + return unless $necessary; + + for my $super (@supers) { + if (!$self->_class_metaclass_is_compatible($super->name)) { + $self->_fix_class_metaclass_incompatibility($super); + } + } + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + for my $super (@supers) { + if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) { + $self->_fix_single_metaclass_incompatibility( + $metaclass_type, $super + ); + } + } + } +} + +sub _can_fix_metaclass_incompatibility { + my $self = shift; + my ($super_meta) = @_; + + return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta); + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type); + } + + return; +} + +sub _class_metaclass_can_be_made_compatible { + my $self = shift; + my ($super_meta) = @_; + + return $self->_can_be_made_compatible_with($super_meta->_real_ref_name); +} + +sub _single_metaclass_can_be_made_compatible { + my $self = shift; + my ($super_meta, $metaclass_type) = @_; + + my $specific_meta = $self->$metaclass_type; + + return unless $super_meta->can($metaclass_type); + my $super_specific_meta = $super_meta->$metaclass_type; + + # for instance, Moose::Meta::Class has a destructor_class, but + # Class::MOP::Class doesn't - this shouldn't be an error + return unless defined $super_specific_meta; + + # if metaclass is defined in superclass but not here, it's fixable + # this is a really odd case + return 1 unless defined $specific_meta; + + return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta); +} + +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ( $super_meta ) = @_; + + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { + ($self->is_pristine) + || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name, + superclass => $super_meta + ); + + my $super_meta_name = $super_meta->_real_ref_name; + + $self->_make_compatible_with($super_meta_name); + } +} + +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ( $metaclass_type, $super_meta ) = @_; + + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name, + superclass => $super_meta, + metaclass_type => $metaclass_type + ); + + my $new_metaclass = $self->$metaclass_type + ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type) + : $super_meta->$metaclass_type; + $self->{$metaclass_type} = $new_metaclass; + } +} + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->_restore_metamethods_from($old_meta); + $self->_restore_metaattributes_from($old_meta); +} + +sub _remove_generated_metaobjects { + my $self = shift; + + for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) { + $attr->remove_accessors; + } +} + +# creating classes with MOP ... + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + (ref $options{superclasses} eq 'ARRAY') + || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfSuperclasses => class => $class, + params => \%options + ) + if exists $options{superclasses}; + + (ref $options{attributes} eq 'ARRAY') + || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfAttributes => class => $class, + params => \%options + ) + if exists $options{attributes}; + + (ref $options{methods} eq 'HASH') + || __PACKAGE__->_throw_exception( CreateMOPClassTakesHashRefOfMethods => class => $class, + params => \%options + ) + if exists $options{methods}; + + my $package = delete $options{package}; + my $superclasses = delete $options{superclasses}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_add_meta_method($meta_name) + if defined $meta_name; + + $meta->superclasses(@{$superclasses}) + if defined $superclasses; + # NOTE: + # process attributes first, so that they can + # install accessors, but locally defined methods + # can then overwrite them. It is maybe a little odd, but + # I think this should be the order of things. + if (defined $attributes) { + foreach my $attr (@{$attributes}) { + $meta->add_attribute($attr); + } + } + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); + } + } + return $meta; +} + +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' } + +sub create_anon_class { shift->create_anon(@_) } +sub is_anon_class { shift->is_anon(@_) } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + # Makes something like Super::Class|Super::Class::2 + return join '=' => ( + join( '|', sort @{ $options{superclasses} || [] } ), + ); +} + +# Instance Construction & Cloning + +sub new_object { + my $class = shift; + + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, so we + # delegate this to &construct_class_instance + # which will deal with the singletons + return $class->_construct_class_instance(@_) + if $class->name->isa('Class::MOP::Class'); + return $class->_construct_instance(@_); +} + +sub _construct_instance { + 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 inheritance, so we might + # have to kludge it in the end. + my $instance; + if (my $instance_class = blessed($params->{__INSTANCE__})) { + ($instance_class eq $class->name) + || $class->_throw_exception( InstanceBlessedIntoWrongClass => class_name => $class->name, + params => $params, + instance => $params->{__INSTANCE__} + ); + $instance = $params->{__INSTANCE__}; + } + elsif (exists $params->{__INSTANCE__}) { + $class->_throw_exception( InstanceMustBeABlessedReference => class_name => $class->name, + params => $params, + instance => $params->{__INSTANCE__} + ); + } + else { + $instance = $meta_instance->create_instance(); + } + foreach my $attr ($class->get_all_attributes()) { + $attr->initialize_instance_slot($meta_instance, $instance, $params); + } + if (Class::MOP::metaclass_is_weak($class->name)) { + $meta_instance->_set_mop_slot($instance, $class); + } + return $instance; +} + +sub _inline_new_object { + my $self = shift; + + return ( + 'my $class = shift;', + '$class = Scalar::Util::blessed($class) || $class;', + $self->_inline_fallback_constructor('$class'), + $self->_inline_params('$params', '$class'), + $self->_inline_generate_instance('$instance', '$class'), + $self->_inline_slot_initializers, + $self->_inline_preserve_weak_metaclasses, + $self->_inline_extra_init, + 'return $instance', + ); +} + +sub _inline_fallback_constructor { + my $self = shift; + my ($class) = @_; + return ( + 'return ' . $self->_generate_fallback_constructor($class), + 'if ' . $class . ' ne \'' . $self->name . '\';', + ); +} + +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)', +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};', + ); +} + +sub _inline_generate_instance { + my $self = shift; + my ($inst, $class) = @_; + return ( + 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';', + ); +} + +sub _inline_create_instance { + my $self = shift; + + return $self->get_meta_instance->inline_create_instance(@_); +} + +sub _inline_slot_initializers { + my $self = shift; + + my $idx = 0; + + return map { $self->_inline_slot_initializer($_, $idx++) } + sort { $a->name cmp $b->name } $self->get_all_attributes; +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $idx) = @_; + + if (defined(my $init_arg = $attr->init_arg)) { + my @source = ( + 'if (exists $params->{\'' . $init_arg . '\'}) {', + $self->_inline_init_attr_from_constructor($attr, $idx), + '}', + ); + if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { + push @source, ( + 'else {', + @default, + '}', + ); + } + return @source; + } + elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { + return ( + '{', + @default, + '}', + ); + } + else { + return (); + } +} + +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', '$params->{\'' . $attr->init_arg . '\'}', + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $idx) = @_; + + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; + + my @initial_value = $attr->_inline_set_value('$instance', $default); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_default_value { + my $self = shift; + my ($attr, $index) = @_; + + if ($attr->has_default) { + # NOTE: + # default values can either be CODE refs + # in which case we need to call them. Or + # they can be scalars (strings/numbers) + # in which case we can just deal with them + # in the code we eval. + if ($attr->is_default_a_coderef) { + return '$defaults->[' . $index . ']->($instance)'; + } + else { + return '$defaults->[' . $index . ']'; + } + } + elsif ($attr->has_builder) { + return '$instance->' . $attr->builder; + } + else { + return; + } +} + +sub _inline_preserve_weak_metaclasses { + my $self = shift; + if (Class::MOP::metaclass_is_weak($self->name)) { + return ( + $self->_inline_set_mop_slot( + '$instance', 'Class::MOP::class_of($class)' + ) . ';' + ); + } + else { + return (); + } +} + +sub _inline_extra_init { } + +sub _eval_environment { + my $self = shift; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + + my $defaults = [map { $_->default } @attrs]; + + return { + '$defaults' => \$defaults, + }; +} + + +sub get_meta_instance { + my $self = shift; + $self->{'_meta_instance'} ||= $self->_create_meta_instance(); +} + +sub _create_meta_instance { + my $self = shift; + + my $instance = $self->instance_metaclass->new( + associated_metaclass => $self, + attributes => [ $self->get_all_attributes() ], + ); + + $self->add_meta_instance_dependencies() + if $instance->is_dependent_on_superclasses(); + + return $instance; +} + +# TODO: this is actually not being used! +sub _inline_rebless_instance { + my $self = shift; + + return $self->get_meta_instance->inline_rebless_instance_structure(@_); +} + +sub _inline_get_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_get_mop_slot(@_); +} + +sub _inline_set_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_set_mop_slot(@_); +} + +sub _inline_clear_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_clear_mop_slot(@_); +} + +sub clone_object { + my $class = shift; + my $instance = shift; + (blessed($instance) && $instance->isa($class->name)) + || $class->_throw_exception( CloneObjectExpectsAnInstanceOfMetaclass => class_name => $class->name, + instance => $instance, + ); + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, they + # should not be cloned. + return $instance if $instance->isa('Class::MOP::Class'); + $class->_clone_instance($instance, @_); +} + +sub _clone_instance { + my ($class, $instance, %params) = @_; + (blessed($instance)) + || $class->_throw_exception( OnlyInstancesCanBeCloned => class_name => $class->name, + instance => $instance, + params => \%params + ); + my $meta_instance = $class->get_meta_instance(); + my $clone = $meta_instance->clone_instance($instance); + foreach my $attr ($class->get_all_attributes()) { + if ( defined( my $init_arg = $attr->init_arg ) ) { + if (exists $params{$init_arg}) { + $attr->set_value($clone, $params{$init_arg}); + } + } + } + return $clone; +} + +sub _force_rebless_instance { + my ($self, $instance, %params) = @_; + my $old_metaclass = Class::MOP::class_of($instance); + + $old_metaclass->rebless_instance_away($instance, $self, %params) + if $old_metaclass; + + my $meta_instance = $self->get_meta_instance; + + if (Class::MOP::metaclass_is_weak($old_metaclass->name)) { + $meta_instance->_clear_mop_slot($instance); + } + + # rebless! + # we use $_[1] here because of t/cmop/rebless_overload.t regressions + # on 5.8.8 + $meta_instance->rebless_instance_structure($_[1], $self); + + $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params); + + if (Class::MOP::metaclass_is_weak($self->name)) { + $meta_instance->_set_mop_slot($instance, $self); + } +} + +sub rebless_instance { + my ($self, $instance, %params) = @_; + my $old_metaclass = Class::MOP::class_of($instance); + + my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance); + $self->name->isa($old_class) + || $self->_throw_exception( CanReblessOnlyIntoASubclass => class_name => $self->name, + instance => $instance, + instance_class => blessed( $instance ), + params => \%params, + ); + + $self->_force_rebless_instance($_[1], %params); + + return $instance; +} + +sub rebless_instance_back { + my ( $self, $instance ) = @_; + my $old_metaclass = Class::MOP::class_of($instance); + my $old_class + = $old_metaclass ? $old_metaclass->name : blessed($instance); + $old_class->isa( $self->name ) + || $self->_throw_exception( CanReblessOnlyIntoASuperclass => class_name => $self->name, + instance => $instance, + instance_class => blessed( $instance ), + ); + + $self->_force_rebless_instance($_[1]); + + return $instance; +} + +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + +sub _fixup_attributes_after_rebless { + my $self = shift; + my ($instance, $rebless_from, %params) = @_; + my $meta_instance = $self->get_meta_instance; + + for my $attr ( $rebless_from->get_all_attributes ) { + next if $self->find_attribute_by_name( $attr->name ); + $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots; + } + + foreach my $attr ( $self->get_all_attributes ) { + if ( $attr->has_value($instance) ) { + if ( defined( my $init_arg = $attr->init_arg ) ) { + $params{$init_arg} = $attr->get_value($instance) + unless exists $params{$init_arg}; + } + else { + $attr->set_value($instance, $attr->get_value($instance)); + } + } + } + + foreach my $attr ($self->get_all_attributes) { + $attr->initialize_instance_slot($meta_instance, $instance, \%params); + } +} + +sub _attach_attribute { + my ($self, $attribute) = @_; + $attribute->attach_to_class($self); +} + +sub _post_add_attribute { + my ( $self, $attribute ) = @_; + + $self->invalidate_meta_instances; + + # invalidate package flag here + try { + local $SIG{__DIE__}; + $attribute->install_accessors; + } + catch { + $self->remove_attribute( $attribute->name ); + die $_; + }; +} + +sub remove_attribute { + my $self = shift; + + my $removed_attribute = $self->SUPER::remove_attribute(@_) + or return; + + $self->invalidate_meta_instances; + + $removed_attribute->remove_accessors; + $removed_attribute->detach_from_class; + + return$removed_attribute; +} + +sub find_attribute_by_name { + my ( $self, $attr_name ) = @_; + + foreach my $class ( $self->linearized_isa ) { + # fetch the meta-class ... + my $meta = Class::MOP::Class->initialize($class); + return $meta->get_attribute($attr_name) + if $meta->has_attribute($attr_name); + } + + return; +} + +sub get_all_attributes { + my $self = shift; + my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } } + reverse $self->linearized_isa; + return values %attrs; +} + +# Inheritance + +sub superclasses { + my $self = shift; + + my $isa = $self->get_or_add_package_symbol('@ISA'); + + if (@_) { + my @supers = @_; + @{$isa} = @supers; + + # NOTE: + # on 5.8 and below, we need to call + # a method to get Perl to detect + # a cycle in the class hierarchy + my $class = $self->name; + $class->isa($class); + + # NOTE: + # we need to check the metaclass + # compatibility here so that we can + # be sure that the superclass is + # not potentially creating an issues + # we don't know about + + $self->_check_metaclass_compatibility(); + $self->_superclasses_updated(); + } + + return @{$isa}; +} + +sub _superclasses_updated { + my $self = shift; + $self->update_meta_instance_dependencies(); + # keep strong references to all our parents, so they don't disappear if + # they are anon classes and don't have any direct instances + $self->_superclass_metas( + map { Class::MOP::class_of($_) } $self->superclasses + ); +} + +sub _superclass_metas { + my $self = shift; + $self->{_superclass_metas} = [@_]; +} + +sub subclasses { + my $self = shift; + my $super_class = $self->name; + + return @{ $super_class->mro::get_isarev() }; +} + +sub direct_subclasses { + my $self = shift; + my $super_class = $self->name; + + return grep { + grep { + $_ eq $super_class + } Class::MOP::Class->initialize($_)->superclasses + } $self->subclasses; +} + +sub linearized_isa { + return @{ mro::get_linear_isa( (shift)->name ) }; +} + +sub class_precedence_list { + my $self = shift; + my $name = $self->name; + + unless (Class::MOP::IS_RUNNING_ON_5_10()) { + # NOTE: + # We need to check for circular inheritance here + # if we are not on 5.10, cause 5.8 detects it late. + # This will do nothing if all is well, and blow up + # otherwise. Yes, it's an ugly hack, better + # suggestions are welcome. + # - SL + ($name || return)->isa('This is a test for circular inheritance') + } + + # if our mro is c3, we can + # just grab the linear_isa + if (mro::get_mro($name) eq 'c3') { + return @{ mro::get_linear_isa($name) } + } + else { + # NOTE: + # we can't grab the linear_isa for dfs + # since it has all the duplicates + # already removed. + return ( + $name, + map { + Class::MOP::Class->initialize($_)->class_precedence_list() + } $self->superclasses() + ); + } +} + +sub _method_lookup_order { + return (shift->linearized_isa, 'UNIVERSAL'); +} + +## Methods + +{ + my $fetch_and_prepare_method = sub { + my ($self, $method_name) = @_; + my $wrapped_metaclass = $self->wrapped_method_metaclass; + # fetch it locally + my $method = $self->get_method($method_name); + # if we don't have local ... + unless ($method) { + # try to find the next method + $method = $self->find_next_method_by_name($method_name); + # die if it does not exist + (defined $method) + || $self->_throw_exception( MethodNameNotFoundInInheritanceHierarchy => class_name => $self->name, + method_name => $method_name + ); + # and now make sure to wrap it + # even if it is already wrapped + # because we need a new sub ref + $method = $wrapped_metaclass->wrap($method, + package_name => $self->name, + name => $method_name, + ); + } + else { + # now make sure we wrap it properly + $method = $wrapped_metaclass->wrap($method, + package_name => $self->name, + name => $method_name, + ) unless $method->isa($wrapped_metaclass); + } + $self->add_method($method_name => $method); + return $method; + }; + + sub add_before_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name ); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_before_modifier( + subname(':before' => $method_modifier) + ); + } + + sub add_after_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name ); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_after_modifier( + subname(':after' => $method_modifier) + ); + } + + sub add_around_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name ); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_around_modifier( + subname(':around' => $method_modifier) + ); + } + + # NOTE: + # the methods above used to be named like this: + # ${pkg}::${method}:(before|after|around) + # but this proved problematic when using one modifier + # to wrap multiple methods (something which is likely + # to happen pretty regularly IMO). So instead of naming + # it like this, I have chosen to just name them purely + # with their modifier names, like so: + # :(before|after|around) + # The fact is that in a stack trace, it will be fairly + # evident from the context what method they are attached + # to, and so don't need the fully qualified name. +} + +sub find_method_by_name { + my ($self, $method_name) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name ); + foreach my $class ($self->_method_lookup_order) { + my $method = Class::MOP::Class->initialize($class)->get_method($method_name); + return $method if defined $method; + } + return; +} + +sub get_all_methods { + my $self = shift; + + my %methods; + for my $class ( reverse $self->_method_lookup_order ) { + my $meta = Class::MOP::Class->initialize($class); + + $methods{ $_->name } = $_ for $meta->_get_local_methods; + } + + return values %methods; +} + +sub get_all_method_names { + my $self = shift; + map { $_->name } $self->get_all_methods; +} + +sub find_all_methods_by_name { + my ($self, $method_name) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name ); + my @methods; + foreach my $class ($self->_method_lookup_order) { + # fetch the meta-class ... + my $meta = Class::MOP::Class->initialize($class); + push @methods => { + name => $method_name, + class => $class, + code => $meta->get_method($method_name) + } if $meta->has_method($method_name); + } + return @methods; +} + +sub find_next_method_by_name { + my ($self, $method_name) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name ); + my @cpl = ($self->_method_lookup_order); + shift @cpl; # discard ourselves + foreach my $class (@cpl) { + my $method = Class::MOP::Class->initialize($class)->get_method($method_name); + return $method if defined $method; + } + return; +} + +sub update_meta_instance_dependencies { + my $self = shift; + + if ( $self->{meta_instance_dependencies} ) { + return $self->add_meta_instance_dependencies; + } +} + +sub add_meta_instance_dependencies { + my $self = shift; + + $self->remove_meta_instance_dependencies; + + my @attrs = $self->get_all_attributes(); + + my %seen; + my @classes = grep { not $seen{ $_->name }++ } + map { $_->associated_class } @attrs; + + foreach my $class (@classes) { + $class->add_dependent_meta_instance($self); + } + + $self->{meta_instance_dependencies} = \@classes; +} + +sub remove_meta_instance_dependencies { + my $self = shift; + + if ( my $classes = delete $self->{meta_instance_dependencies} ) { + foreach my $class (@$classes) { + $class->remove_dependent_meta_instance($self); + } + + return $classes; + } + + return; + +} + +sub add_dependent_meta_instance { + my ( $self, $metaclass ) = @_; + push @{ $self->{dependent_meta_instances} }, $metaclass; +} + +sub remove_dependent_meta_instance { + my ( $self, $metaclass ) = @_; + my $name = $metaclass->name; + @$_ = grep { $_->name ne $name } @$_ + for $self->{dependent_meta_instances}; +} + +sub invalidate_meta_instances { + my $self = shift; + $_->invalidate_meta_instance() + for $self, @{ $self->{dependent_meta_instances} }; +} + +sub invalidate_meta_instance { + my $self = shift; + undef $self->{_meta_instance}; +} + +# check if we can reinitialize +sub is_pristine { + my $self = shift; + + # if any local attr is defined + return if $self->get_attribute_list; + + # or any non-declared methods + for my $method ( map { $self->get_method($_) } $self->get_method_list ) { + return if $method->isa("Class::MOP::Method::Generated"); + # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass ); + } + + return 1; +} + +## Class closing + +sub is_mutable { 1 } +sub is_immutable { 0 } + +sub immutable_options { %{ $_[0]{__immutable}{options} || {} } } + +sub _immutable_options { + my ( $self, @args ) = @_; + + return ( + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => $self->immutable_trait, + constructor_name => $self->constructor_name, + constructor_class => $self->constructor_class, + destructor_class => $self->destructor_class, + @args, + ); +} + +sub make_immutable { + my ( $self, @args ) = @_; + + return $self unless $self->is_mutable; + + my ($file, $line) = (caller)[1..2]; + + $self->_initialize_immutable( + file => $file, + line => $line, + $self->_immutable_options(@args), + ); + $self->_rebless_as_immutable(@args); + + return $self; +} + +sub make_mutable { + my $self = shift; + + if ( $self->is_immutable ) { + my @args = $self->immutable_options; + $self->_rebless_as_mutable(); + $self->_remove_inlined_code(@args); + delete $self->{__immutable}; + return $self; + } + else { + return; + } +} + +sub _rebless_as_immutable { + my ( $self, @args ) = @_; + + $self->{__immutable}{original_class} = ref $self; + + bless $self => $self->_immutable_metaclass(@args); +} + +sub _immutable_metaclass { + my ( $self, %args ) = @_; + + if ( my $class = $args{immutable_metaclass} ) { + return $class; + } + + my $trait = $args{immutable_trait} = $self->immutable_trait + || $self->_throw_exception( NoImmutableTraitSpecifiedForClass => class_name => $self->name, + params => \%args + ); + + my $meta = $self->meta; + my $meta_attr = $meta->find_attribute_by_name("immutable_trait"); + + my $class_name; + + if ( $meta_attr and $trait eq $meta_attr->default ) { + # if the trait is the same as the default we try and pick a + # predictable name for the immutable metaclass + $class_name = 'Class::MOP::Class::Immutable::' . ref($self); + } + else { + $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait', + $trait, 'ForMetaClass', ref($self); + } + + return $class_name + if Class::MOP::does_metaclass_exist($class_name); + + # If the metaclass is a subclass of CMOP::Class which has had + # metaclass roles applied (via Moose), then we want to make sure + # that we preserve that anonymous class (see Fey::ORM for an + # example of where this matters). + my $meta_name = $meta->_real_ref_name; + + my $immutable_meta = $meta_name->create( + $class_name, + superclasses => [ ref $self ], + ); + + Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); + + $immutable_meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, + ); + + return $class_name; +} + +sub _remove_inlined_code { + my $self = shift; + + $self->remove_method( $_->name ) for $self->_inlined_methods; + + delete $self->{__immutable}{inlined_methods}; +} + +sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } } + +sub _add_inlined_method { + my ( $self, $method ) = @_; + + push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method; +} + +sub _initialize_immutable { + my ( $self, %args ) = @_; + + $self->{__immutable}{options} = \%args; + $self->_install_inlined_code(%args); +} + +sub _install_inlined_code { + my ( $self, %args ) = @_; + + # FIXME + $self->_inline_accessors(%args) if $args{inline_accessors}; + $self->_inline_constructor(%args) if $args{inline_constructor}; + $self->_inline_destructor(%args) if $args{inline_destructor}; +} + +sub _rebless_as_mutable { + my $self = shift; + + bless $self, $self->_get_mutable_metaclass_name; + + return $self; +} + +sub _inline_accessors { + my $self = shift; + + foreach my $attr_name ( $self->get_attribute_list ) { + $self->get_attribute($attr_name)->install_accessors(1); + } +} + +sub _inline_constructor { + my ( $self, %args ) = @_; + + my $name = $args{constructor_name}; + # A class may not even have a constructor, and that's okay. + return unless defined $name; + + if ( $self->has_method($name) && !$args{replace_constructor} ) { + my $class = $self->name; + warn "Not inlining a constructor for $class since it defines" + . " its own constructor.\n" + . "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + return; + } + + my $constructor_class = $args{constructor_class}; + + { + local $@; + use_package_optimistically($constructor_class); + } + + my $constructor = $constructor_class->new( + options => \%args, + metaclass => $self, + is_inline => 1, + package_name => $self->name, + name => $name, + definition_context => { + description => "constructor " . $self->name . "::" . $name, + file => $args{file}, + line => $args{line}, + }, + ); + + if ( $args{replace_constructor} or $constructor->can_be_inlined ) { + $self->add_method( $name => $constructor ); + $self->_add_inlined_method($constructor); + } +} + +sub _inline_destructor { + my ( $self, %args ) = @_; + + ( exists $args{destructor_class} && defined $args{destructor_class} ) + || $self->_throw_exception( NoDestructorClassSpecified => class_name => $self->name, + params => \%args, + ); + + if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) { + my $class = $self->name; + warn "Not inlining a destructor for $class since it defines" + . " its own destructor.\n"; + return; + } + + my $destructor_class = $args{destructor_class}; + + { + local $@; + use_package_optimistically($destructor_class); + } + + return unless $destructor_class->is_needed($self); + + my $destructor = $destructor_class->new( + options => \%args, + metaclass => $self, + package_name => $self->name, + name => 'DESTROY', + definition_context => { + description => "destructor " . $self->name . "::DESTROY", + file => $args{file}, + line => $args{line}, + }, + ); + + if ( $args{replace_destructor} or $destructor->can_be_inlined ) { + $self->add_method( 'DESTROY' => $destructor ); + $self->_add_inlined_method($destructor); + } +} + +1; + +# ABSTRACT: Class Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Class - Class Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + # assuming that class Foo + # has been defined, you can + + # use this for introspection ... + + # add a method to Foo ... + Foo->meta->add_method( 'bar' => sub {...} ) + + # get a list of all the classes searched + # the method dispatcher in the correct order + Foo->meta->class_precedence_list() + + # remove a method from Foo + Foo->meta->remove_method('bar'); + + # or use this to actually create classes ... + + Class::MOP::Class->create( + 'Bar' => ( + version => '0.01', + superclasses => ['Foo'], + attributes => [ + Class::MOP::Attribute->new('$bar'), + Class::MOP::Attribute->new('$baz'), + ], + methods => { + calculate_bar => sub {...}, + construct_baz => sub {...} + } + ) + ); + +=head1 DESCRIPTION + +The Class Protocol is the largest and most complex part of the +Class::MOP meta-object protocol. It controls the introspection and +manipulation of Perl 5 classes, and it can create them as well. The +best way to understand what this module can do is to read the +documentation for each of its methods. + +=head1 INHERITANCE + +C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>. + +=head1 METHODS + +=head2 Class construction + +These methods all create new C<Class::MOP::Class> objects. These +objects can represent existing classes or they can be used to create +new classes from scratch. + +The metaclass object for a given class is a singleton. If you attempt +to create a metaclass for the same class twice, you will just get the +existing object. + +=over 4 + +=item B<< Class::MOP::Class->create($package_name, %options) >> + +This method creates a new C<Class::MOP::Class> object with the given +package name. It accepts a number of options: + +=over 8 + +=item * version + +An optional version number for the newly created package. + +=item * authority + +An optional authority for the newly created package. +See L<Class::MOP::Module/authority> for more details. + +=item * superclasses + +An optional array reference of superclass names. + +=item * methods + +An optional hash reference of methods for the class. The keys of the +hash reference are method names and values are subroutine references. + +=item * attributes + +An optional array reference of L<Class::MOP::Attribute> objects. + +=item * meta_name + +Specifies the name to install the C<meta> method for this class under. +If it is not passed, C<meta> is assumed, and if C<undef> is explicitly +given, no meta method will be installed. + +=item * weaken + +If true, the metaclass that is stored in the global cache will be a +weak reference. + +Classes created in this way are destroyed once the metaclass they are +attached to goes out of scope, and will be removed from Perl's internal +symbol table. + +All instances of a class with a weakened metaclass keep a special +reference to the metaclass object, which prevents the metaclass from +going out of scope while any instances exist. + +This only works if the instance is based on a hash reference, however. + +=back + +=item B<< Class::MOP::Class->create_anon_class(%options) >> + +This method works just like C<< Class::MOP::Class->create >> but it +creates an "anonymous" class. In fact, the class does have a name, but +that name is a unique name generated internally by this module. + +It accepts the same C<superclasses>, C<methods>, and C<attributes> +parameters that C<create> accepts. + +It also accepts a C<cache> option. If this is C<true>, then the anonymous class +will be cached based on its superclasses and roles. If an existing anonymous +class in the cache has the same superclasses and roles, it will be reused. + +Anonymous classes default to C<< weaken => 1 >> if cache is C<false>, although +this can be overridden. + +=item B<< Class::MOP::Class->initialize($package_name, %options) >> + +This method will initialize a C<Class::MOP::Class> object for the +named package. Unlike C<create>, this method I<will not> create a new +class. + +The purpose of this method is to retrieve a C<Class::MOP::Class> +object for introspecting an existing class. + +If an existing C<Class::MOP::Class> object exists for the named +package, it will be returned, and any options provided will be +ignored! + +If the object does not yet exist, it will be created. + +The valid options that can be passed to this method are +C<attribute_metaclass>, C<method_metaclass>, +C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all +optional, and default to the appropriate class in the C<Class::MOP> +distribution. + +=back + +=head2 Object instance construction and cloning + +These methods are all related to creating and/or cloning object +instances. + +=over 4 + +=item B<< $metaclass->clone_object($instance, %params) >> + +This method clones an existing object instance. Any parameters you +provide are will override existing attribute values in the object. + +This is a convenience method for cloning an object instance, then +blessing it into the appropriate package. + +You could implement a clone method in your class, using this method: + + sub clone { + my ($self, %params) = @_; + $self->meta->clone_object($self, %params); + } + +=item B<< $metaclass->rebless_instance($instance, %params) >> + +This method changes the class of C<$instance> to the metaclass's class. + +You can only rebless an instance into a subclass of its current +class. If you pass any additional parameters, these will be treated +like constructor parameters and used to initialize the object's +attributes. Any existing attributes that are already set will be +overwritten. + +Before reblessing the instance, this method will call +C<rebless_instance_away> on the instance's current metaclass. This method +will be passed the instance, the new metaclass, and any parameters +specified to C<rebless_instance>. By default, C<rebless_instance_away> +does nothing; it is merely a hook. + +=item B<< $metaclass->rebless_instance_back($instance) >> + +Does the same thing as C<rebless_instance>, except that you can only +rebless an instance into one of its superclasses. Any attributes that +do not exist in the superclass will be deinitialized. + +This is a much more dangerous operation than C<rebless_instance>, +especially when multiple inheritance is involved, so use this carefully! + +=item B<< $metaclass->new_object(%params) >> + +This method is used to create a new object of the metaclass's +class. Any parameters you provide are used to initialize the +instance's attributes. A special C<__INSTANCE__> key can be passed to +provide an already generated instance, rather than having Class::MOP +generate it for you. This is mostly useful for using Class::MOP with +foreign classes which generate instances using their own constructors. + +=item B<< $metaclass->instance_metaclass >> + +Returns the class name of the instance metaclass. See +L<Class::MOP::Instance> for more information on the instance +metaclass. + +=item B<< $metaclass->get_meta_instance >> + +Returns an instance of the C<instance_metaclass> to be used in the +construction of a new instance of the class. + +=back + +=head2 Informational predicates + +These are a few predicate methods for asking information about the +class itself. + +=over 4 + +=item B<< $metaclass->is_anon_class >> + +This returns true if the class was created by calling C<< +Class::MOP::Class->create_anon_class >>. + +=item B<< $metaclass->is_mutable >> + +This returns true if the class is still mutable. + +=item B<< $metaclass->is_immutable >> + +This returns true if the class has been made immutable. + +=item B<< $metaclass->is_pristine >> + +A class is I<not> pristine if it has non-inherited attributes or if it +has any generated methods. + +=back + +=head2 Inheritance Relationships + +=over 4 + +=item B<< $metaclass->superclasses(@superclasses) >> + +This is a read-write accessor which represents the superclass +relationships of the metaclass's class. + +This is basically sugar around getting and setting C<@ISA>. + +=item B<< $metaclass->class_precedence_list >> + +This returns a list of all of the class's ancestor classes. The +classes are returned in method dispatch order. + +=item B<< $metaclass->linearized_isa >> + +This returns a list based on C<class_precedence_list> but with all +duplicates removed. + +=item B<< $metaclass->subclasses >> + +This returns a list of all subclasses for this class, even indirect +subclasses. + +=item B<< $metaclass->direct_subclasses >> + +This returns a list of immediate subclasses for this class, which does not +include indirect subclasses. + +=back + +=head2 Method introspection and creation + +These methods allow you to introspect a class's methods, as well as +add, remove, or change methods. + +Determining what is truly a method in a Perl 5 class requires some +heuristics (aka guessing). + +Methods defined outside the package with a fully qualified name (C<sub +Package::name { ... }>) will be included. Similarly, methods named +with a fully qualified name using L<Sub::Name> are also included. + +However, we attempt to ignore imported functions. + +Ultimately, we are using heuristics to determine what truly is a +method in a class, and these heuristics may get the wrong answer in +some edge cases. However, for most "normal" cases the heuristics work +correctly. + +=over 4 + +=item B<< $metaclass->get_method($method_name) >> + +This will return a L<Class::MOP::Method> for the specified +C<$method_name>. If the class does not have the specified method, it +returns C<undef> + +=item B<< $metaclass->has_method($method_name) >> + +Returns a boolean indicating whether or not the class defines the +named method. It does not include methods inherited from parent +classes. + +=item B<< $metaclass->get_method_list >> + +This will return a list of method I<names> for all methods defined in +this class. + +=item B<< $metaclass->add_method($method_name, $method) >> + +This method takes a method name and a subroutine reference, and adds +the method to the class. + +The subroutine reference can be a L<Class::MOP::Method>, and you are +strongly encouraged to pass a meta method object instead of a code +reference. If you do so, that object gets stored as part of the +class's method map directly. If not, the meta information will have to +be recreated later, and may be incorrect. + +If you provide a method object, this method will clone that object if +the object's package name does not match the class name. This lets us +track the original source of any methods added from other classes +(notably Moose roles). + +=item B<< $metaclass->remove_method($method_name) >> + +Remove the named method from the class. This method returns the +L<Class::MOP::Method> object for the method. + +=item B<< $metaclass->method_metaclass >> + +Returns the class name of the method metaclass, see +L<Class::MOP::Method> for more information on the method metaclass. + +=item B<< $metaclass->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L<Class::MOP::Method::Wrapped> for more information on the wrapped +method metaclass. + +=item B<< $metaclass->get_all_methods >> + +This will traverse the inheritance hierarchy and return a list of all +the L<Class::MOP::Method> objects for this class and its parents. + +=item B<< $metaclass->find_method_by_name($method_name) >> + +This will return a L<Class::MOP::Method> for the specified +C<$method_name>. If the class does not have the specified method, it +returns C<undef> + +Unlike C<get_method>, this method I<will> look for the named method in +superclasses. + +=item B<< $metaclass->get_all_method_names >> + +This will return a list of method I<names> for all of this class's +methods, including inherited methods. + +=item B<< $metaclass->find_all_methods_by_name($method_name) >> + +This method looks for the named method in the class and all of its +parents. It returns every matching method it finds in the inheritance +tree, so it returns a list of methods. + +Each method is returned as a hash reference with three keys. The keys +are C<name>, C<class>, and C<code>. The C<code> key has a +L<Class::MOP::Method> object as its value. + +The list of methods is distinct. + +=item B<< $metaclass->find_next_method_by_name($method_name) >> + +This method returns the first method in any superclass matching the +given name. It is effectively the method that C<SUPER::$method_name> +would dispatch to. + +=back + +=head2 Attribute introspection and creation + +Because Perl 5 does not have a core concept of attributes in classes, +we can only return information about attributes which have been added +via this class's methods. We cannot discover information about +attributes which are defined in terms of "regular" Perl 5 methods. + +=over 4 + +=item B<< $metaclass->get_attribute($attribute_name) >> + +This will return a L<Class::MOP::Attribute> for the specified +C<$attribute_name>. If the class does not have the specified +attribute, it returns C<undef>. + +NOTE that get_attribute does not search superclasses, for that you +need to use C<find_attribute_by_name>. + +=item B<< $metaclass->has_attribute($attribute_name) >> + +Returns a boolean indicating whether or not the class defines the +named attribute. It does not include attributes inherited from parent +classes. + +=item B<< $metaclass->get_attribute_list >> + +This will return a list of attributes I<names> for all attributes +defined in this class. Note that this operates on the current class +only, it does not traverse the inheritance hierarchy. + +=item B<< $metaclass->get_all_attributes >> + +This will traverse the inheritance hierarchy and return a list of all +the L<Class::MOP::Attribute> objects for this class and its parents. + +=item B<< $metaclass->find_attribute_by_name($attribute_name) >> + +This will return a L<Class::MOP::Attribute> for the specified +C<$attribute_name>. If the class does not have the specified +attribute, it returns C<undef>. + +Unlike C<get_attribute>, this attribute I<will> look for the named +attribute in superclasses. + +=item B<< $metaclass->add_attribute(...) >> + +This method accepts either an existing L<Class::MOP::Attribute> +object or parameters suitable for passing to that class's C<new> +method. + +The attribute provided will be added to the class. + +Any accessor methods defined by the attribute will be added to the +class when the attribute is added. + +If an attribute of the same name already exists, the old attribute +will be removed first. + +=item B<< $metaclass->remove_attribute($attribute_name) >> + +This will remove the named attribute from the class, and +L<Class::MOP::Attribute> object. + +Removing an attribute also removes any accessor methods defined by the +attribute. + +However, note that removing an attribute will only affect I<future> +object instances created for this class, not existing instances. + +=item B<< $metaclass->attribute_metaclass >> + +Returns the class name of the attribute metaclass for this class. By +default, this is L<Class::MOP::Attribute>. + +=back + +=head2 Overload introspection and creation + +These methods provide an API to the core L<overload> functionality. + +=over 4 + +=item B<< $metaclass->is_overloaded >> + +Returns true if overloading is enabled for this class. Corresponds to +L<overload::Overloaded|overload/Public Functions>. + +=item B<< $metaclass->get_overloaded_operator($op) >> + +Returns the L<Class::MOP::Overload> object corresponding to the operator named +C<$op>, if one exists for this class. + +=item B<< $metaclass->has_overloaded_operator($op) >> + +Returns whether or not the operator C<$op> is overloaded for this class. + +=item B<< $metaclass->get_overload_list >> + +Returns a list of operator names which have been overloaded (see +L<overload/Overloadable Operations> for the list of valid operator names). + +=item B<< $metaclass->get_all_overloaded_operators >> + +Returns a list of L<Class::MOP::Overload> objects corresponding to the +operators that have been overloaded. + +=item B<< $metaclass->add_overloaded_operator($op, $impl) >> + +Overloads the operator C<$op> for this class. The C<$impl> can be a coderef, a +method name, or a L<Class::MOP::Overload> object. Corresponds to +C<< use overload $op => $impl; >> + +=item B<< $metaclass->remove_overloaded_operator($op) >> + +Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >> + +=item B<< $metaclass->get_overload_fallback_value >> + +Returns the overload C<fallback> setting for the package. + +=item B<< $metaclass->set_overload_fallback_value($fallback) >> + +Sets the overload C<fallback> setting for the package. + +=back + +=head2 Class Immutability + +Making a class immutable "freezes" the class definition. You can no +longer call methods which alter the class, such as adding or removing +methods or attributes. + +Making a class immutable lets us optimize the class by inlining some +methods, and also allows us to optimize some methods on the metaclass +object itself. + +After immutabilization, the metaclass object will cache most informational +methods that returns information about methods or attributes. Methods which +would alter the class, such as C<add_attribute> and C<add_method>, will +throw an error on an immutable metaclass object. + +The immutabilization system in L<Moose> takes much greater advantage +of the inlining features than Class::MOP itself does. + +=over 4 + +=item B<< $metaclass->make_immutable(%options) >> + +This method will create an immutable transformer and use it to make +the class and its metaclass object immutable, and returns true +(you should not rely on the details of this value apart from its truth). + +This method accepts the following options: + +=over 8 + +=item * inline_accessors + +=item * inline_constructor + +=item * inline_destructor + +These are all booleans indicating whether the specified method(s) +should be inlined. + +By default, accessors and the constructor are inlined, but not the +destructor. + +=item * immutable_trait + +The name of a class which will be used as a parent class for the +metaclass object being made immutable. This "trait" implements the +post-immutability functionality of the metaclass (but not the +transformation itself). + +This defaults to L<Class::MOP::Class::Immutable::Trait>. + +=item * constructor_name + +This is the constructor method name. This defaults to "new". + +=item * constructor_class + +The name of the method metaclass for constructors. It will be used to +generate the inlined constructor. This defaults to +"Class::MOP::Method::Constructor". + +=item * replace_constructor + +This is a boolean indicating whether an existing constructor should be +replaced when inlining a constructor. This defaults to false. + +=item * destructor_class + +The name of the method metaclass for destructors. It will be used to +generate the inlined destructor. This defaults to +"Class::MOP::Method::Denstructor". + +=item * replace_destructor + +This is a boolean indicating whether an existing destructor should be +replaced when inlining a destructor. This defaults to false. + +=back + +=item B<< $metaclass->immutable_options >> + +Returns a hash of the options used when making the class immutable, including +both defaults and anything supplied by the user in the call to C<< +$metaclass->make_immutable >>. This is useful if you need to temporarily make +a class mutable and then restore immutability as it was before. + +=item B<< $metaclass->make_mutable >> + +Calling this method reverse the immutabilization transformation. + +=back + +=head2 Method Modifiers + +Method modifiers are hooks which allow a method to be wrapped with +I<before>, I<after> and I<around> method modifiers. Every time a +method is called, its modifiers are also called. + +A class can modify its own methods, as well as methods defined in +parent classes. + +=head3 How method modifiers work? + +Method modifiers work by wrapping the original method and then +replacing it in the class's symbol table. The wrappers will handle +calling all the modifiers in the appropriate order and preserving the +calling context for the original method. + +The return values of C<before> and C<after> modifiers are +ignored. This is because their purpose is B<not> to filter the input +and output of the primary method (this is done with an I<around> +modifier). + +This may seem like an odd restriction to some, but doing this allows +for simple code to be added at the beginning or end of a method call +without altering the function of the wrapped method or placing any +extra responsibility on the code of the modifier. + +Of course if you have more complex needs, you can use the C<around> +modifier which allows you to change both the parameters passed to the +wrapped method, as well as its return value. + +Before and around modifiers are called in last-defined-first-called +order, while after modifiers are called in first-defined-first-called +order. So the call tree might looks something like this: + + before 2 + before 1 + around 2 + around 1 + primary + around 1 + around 2 + after 1 + after 2 + +=head3 What is the performance impact? + +Of course there is a performance cost associated with method +modifiers, but we have made every effort to make that cost directly +proportional to the number of modifier features you use. + +The wrapping method does its best to B<only> do as much work as it +absolutely needs to. In order to do this we have moved some of the +performance costs to set-up time, where they are easier to amortize. + +All this said, our benchmarks have indicated the following: + + simple wrapper with no modifiers 100% slower + simple wrapper with simple before modifier 400% slower + simple wrapper with simple after modifier 450% slower + simple wrapper with simple around modifier 500-550% slower + simple wrapper with all 3 modifiers 1100% slower + +These numbers may seem daunting, but you must remember, every feature +comes with some cost. To put things in perspective, just doing a +simple C<AUTOLOAD> which does nothing but extract the name of the +method called and return it costs about 400% over a normal method +call. + +=over 4 + +=item B<< $metaclass->add_before_method_modifier($method_name, $code) >> + +This wraps the specified method with the supplied subroutine +reference. The modifier will be called as a method itself, and will +receive the same arguments as are passed to the method. + +When the modifier exits, the wrapped method will be called. + +The return value of the modifier will be ignored. + +=item B<< $metaclass->add_after_method_modifier($method_name, $code) >> + +This wraps the specified method with the supplied subroutine +reference. The modifier will be called as a method itself, and will +receive the same arguments as are passed to the method. + +When the wrapped methods exits, the modifier will be called. + +The return value of the modifier will be ignored. + +=item B<< $metaclass->add_around_method_modifier($method_name, $code) >> + +This wraps the specified method with the supplied subroutine +reference. + +The first argument passed to the modifier will be a subroutine +reference to the wrapped method. The second argument is the object, +and after that come any arguments passed when the method is called. + +The around modifier can choose to call the original method, as well as +what arguments to pass if it does so. + +The return value of the modifier is what will be seen by the caller. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Class->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm new file mode 100644 index 0000000..8bb6c93 --- /dev/null +++ b/lib/Class/MOP/Class/Immutable/Trait.pm @@ -0,0 +1,172 @@ +package Class::MOP::Class::Immutable::Trait; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use MRO::Compat; +use Module::Runtime 'use_module'; + +# the original class of the metaclass instance +sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} } + +sub is_mutable { 0 } +sub is_immutable { 1 } + +sub _immutable_metaclass { ref $_[1] } + +sub _immutable_read_only { + my $name = shift; + __throw_exception( CallingReadOnlyMethodOnAnImmutableInstance => method_name => $name ); +} + +sub _immutable_cannot_call { + my $name = shift; + __throw_exception( CallingMethodOnAnImmutableInstance => method_name => $name ); +} + +for my $name (qw/superclasses/) { + no strict 'refs'; + *{__PACKAGE__."::$name"} = sub { + my $orig = shift; + my $self = shift; + _immutable_read_only($name) if @_; + $self->$orig; + }; +} + +for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) { + no strict 'refs'; + *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) }; +} + +sub class_precedence_list { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{class_precedence_list} + ||= [ $self->$orig ] }; +} + +sub linearized_isa { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] }; +} + +sub get_all_methods { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] }; +} + +sub get_all_method_names { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] }; +} + +sub get_all_attributes { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] }; +} + +sub get_meta_instance { + my $orig = shift; + my $self = shift; + $self->{__immutable}{get_meta_instance} ||= $self->$orig; +} + +sub _method_map { + my $orig = shift; + my $self = shift; + $self->{__immutable}{_method_map} ||= $self->$orig; +} + +# private method, for this file only - +# if we declare a method here, it will behave differently depending on what +# class this trait is applied to, so we won't have a reliable parameter list. +sub __throw_exception { + my ($exception_type, @args_to_exception) = @_; + die use_module( "Moose::Exception::$exception_type" )->new( @args_to_exception ); +} + +1; + +# ABSTRACT: Implements immutability for metaclass objects + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class provides a pseudo-trait that is applied to immutable metaclass +objects. In reality, it is simply a parent class. + +It implements caching and read-only-ness for various metaclass methods. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Deprecated.pm b/lib/Class/MOP/Deprecated.pm new file mode 100644 index 0000000..cb9329a --- /dev/null +++ b/lib/Class/MOP/Deprecated.pm @@ -0,0 +1,95 @@ +package Class::MOP::Deprecated; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Package::DeprecationManager -deprecations => { + 'Class::Load wrapper functions' => '2.1100', +}; + +1; + +# ABSTRACT: Manages deprecation warnings for Class::MOP + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Deprecated - Manages deprecation warnings for Class::MOP + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + + use Class::MOP::Deprecated -api_version => $version; + +=head1 FUNCTIONS + +This module manages deprecation warnings for features that have been +deprecated in Class::MOP. + +If you specify C<< -api_version => $version >>, you can use deprecated features +without warnings. Note that this special treatment is limited to the package +that loads C<Class::MOP::Deprecated>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm new file mode 100644 index 0000000..3cffb4e --- /dev/null +++ b/lib/Class/MOP/Instance.pm @@ -0,0 +1,533 @@ +package Class::MOP::Instance; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'isweak', 'weaken', 'blessed'; + +use parent 'Class::MOP::Object'; + +# make this not a valid method name, to avoid (most) attribute conflicts +my $RESERVED_MOP_SLOT = '<<MOP>>'; + +sub BUILDARGS { + my ($class, @args) = @_; + + if ( @args == 1 ) { + unshift @args, "associated_metaclass"; + } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) { + # compat mode + my ( $meta, @attrs ) = @args; + @args = ( associated_metaclass => $meta, attributes => \@attrs ); + } + + my %options = @args; + # FIXME lazy_build + $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ]; + $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build + + return \%options; +} + +sub new { + my $class = shift; + my $options = $class->BUILDARGS(@_); + + # FIXME replace with a proper constructor + my $instance = $class->_new(%$options); + + # FIXME weak_ref => 1, + weaken($instance->{'associated_metaclass'}); + + return $instance; +} + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + return bless { + # NOTE: + # I am not sure that it makes + # sense to pass in the meta + # The ideal would be to just + # pass in the class name, but + # that is placing too much of + # an assumption on bless(), + # which is *probably* a safe + # assumption,.. but you can + # never tell <:) + 'associated_metaclass' => $params->{associated_metaclass}, + 'attributes' => $params->{attributes}, + 'slots' => $params->{slots}, + 'slot_hash' => $params->{slot_hash}, + } => $class; +} + +sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name } + +sub create_instance { + my $self = shift; + bless {}, $self->_class_name; +} + +sub clone_instance { + my ($self, $instance) = @_; + + my $clone = $self->create_instance; + for my $attr ($self->get_all_attributes) { + next unless $attr->has_value($instance); + for my $slot ($attr->slots) { + my $val = $self->get_slot_value($instance, $slot); + $self->set_slot_value($clone, $slot, $val); + $self->weaken_slot_value($clone, $slot) + if $self->slot_value_is_weak($instance, $slot); + } + } + + $self->_set_mop_slot($clone, $self->_get_mop_slot($instance)) + if $self->_has_mop_slot($instance); + + return $clone; +} + +# operations on meta instance + +sub get_all_slots { + my $self = shift; + return @{$self->{'slots'}}; +} + +sub get_all_attributes { + my $self = shift; + return @{$self->{attributes}}; +} + +sub is_valid_slot { + my ($self, $slot_name) = @_; + exists $self->{'slot_hash'}->{$slot_name}; +} + +# operations on created instances + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + $instance->{$slot_name}; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->{$slot_name} = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + return; +} + +sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + delete $instance->{$slot_name}; +} + +sub initialize_all_slots { + my ($self, $instance) = @_; + foreach my $slot_name ($self->get_all_slots) { + $self->initialize_slot($instance, $slot_name); + } +} + +sub deinitialize_all_slots { + my ($self, $instance) = @_; + foreach my $slot_name ($self->get_all_slots) { + $self->deinitialize_slot($instance, $slot_name); + } +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name, $value) = @_; + exists $instance->{$slot_name}; +} + +sub weaken_slot_value { + my ($self, $instance, $slot_name) = @_; + weaken $instance->{$slot_name}; +} + +sub slot_value_is_weak { + my ($self, $instance, $slot_name) = @_; + isweak $instance->{$slot_name}; +} + +sub strengthen_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name)); +} + +sub rebless_instance_structure { + my ($self, $instance, $metaclass) = @_; + + # we use $_[1] here because of t/cmop/rebless_overload.t regressions + # on 5.8.8 + bless $_[1], $metaclass->name; +} + +sub is_dependent_on_superclasses { + return; # for meta instances that require updates on inherited slot changes +} + +sub _get_mop_slot { + my ($self, $instance) = @_; + $self->get_slot_value($instance, $RESERVED_MOP_SLOT); +} + +sub _has_mop_slot { + my ($self, $instance) = @_; + $self->is_slot_initialized($instance, $RESERVED_MOP_SLOT); +} + +sub _set_mop_slot { + my ($self, $instance, $value) = @_; + $self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value); +} + +sub _clear_mop_slot { + my ($self, $instance) = @_; + $self->deinitialize_slot($instance, $RESERVED_MOP_SLOT); +} + +# inlinable operation snippets + +sub is_inlinable { 1 } + +sub inline_create_instance { + my ($self, $class_variable) = @_; + 'bless {} => ' . $class_variable; +} + +sub inline_slot_access { + my ($self, $instance, $slot_name) = @_; + sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name); +} + +sub inline_get_is_lvalue { 1 } + +sub inline_get_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->inline_slot_access($instance, $slot_name); +} + +sub inline_set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->inline_slot_access($instance, $slot_name) . " = $value", +} + +sub inline_initialize_slot { + my ($self, $instance, $slot_name) = @_; + return ''; +} + +sub inline_deinitialize_slot { + my ($self, $instance, $slot_name) = @_; + "delete " . $self->inline_slot_access($instance, $slot_name); +} +sub inline_is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + "exists " . $self->inline_slot_access($instance, $slot_name); +} + +sub inline_weaken_slot_value { + my ($self, $instance, $slot_name) = @_; + sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name); +} + +sub inline_strengthen_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name)); +} + +sub inline_rebless_instance_structure { + my ($self, $instance, $class_variable) = @_; + "bless $instance => $class_variable"; +} + +sub _inline_get_mop_slot { + my ($self, $instance) = @_; + $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT); +} + +sub _inline_set_mop_slot { + my ($self, $instance, $value) = @_; + $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value); +} + +sub _inline_clear_mop_slot { + my ($self, $instance) = @_; + $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT); +} + +1; + +# ABSTRACT: Instance Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Instance - Instance Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Instance Protocol controls the creation of object instances, and +the storage of attribute values in those instances. + +Using this API directly in your own code violates encapsulation, and +we recommend that you use the appropriate APIs in L<Class::MOP::Class> +and L<Class::MOP::Attribute> instead. Those APIs in turn call the +methods in this class as appropriate. + +This class also participates in generating inlined code by providing +snippets of code to access an object instance. + +=head1 METHODS + +=head2 Object construction + +=over 4 + +=item B<< Class::MOP::Instance->new(%options) >> + +This method creates a new meta-instance object. + +It accepts the following keys in C<%options>: + +=over 8 + +=item * associated_metaclass + +The L<Class::MOP::Class> object for which instances will be created. + +=item * attributes + +An array reference of L<Class::MOP::Attribute> objects. These are the +attributes which can be stored in each instance. + +=back + +=back + +=head2 Creating and altering instances + +=over 4 + +=item B<< $metainstance->create_instance >> + +This method returns a reference blessed into the associated +metaclass's class. + +The default is to use a hash reference. Subclasses can override this. + +=item B<< $metainstance->clone_instance($instance) >> + +Given an instance, this method creates a new object by making +I<shallow> clone of the original. + +=back + +=head2 Introspection + +=over 4 + +=item B<< $metainstance->associated_metaclass >> + +This returns the L<Class::MOP::Class> object associated with the +meta-instance object. + +=item B<< $metainstance->get_all_slots >> + +This returns a list of slot names stored in object instances. In +almost all cases, slot names correspond directly attribute names. + +=item B<< $metainstance->is_valid_slot($slot_name) >> + +This will return true if C<$slot_name> is a valid slot name. + +=item B<< $metainstance->get_all_attributes >> + +This returns a list of attributes corresponding to the attributes +passed to the constructor. + +=back + +=head2 Operations on Instance Structures + +It's important to understand that the meta-instance object is a +different entity from the actual instances it creates. For this +reason, any operations on the C<$instance_structure> always require +that the object instance be passed to the method. + +=over 4 + +=item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >> + +=item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >> + +=item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >> + +=item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >> + +=item B<< $metainstance->initialize_all_slots($instance_structure) >> + +=item B<< $metainstance->deinitialize_all_slots($instance_structure) >> + +=item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >> + +=item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >> + +=item B<< $metainstance->slot_value_is_weak($instance_structure, $slot_name) >> + +=item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >> + +=item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >> + +The exact details of what each method does should be fairly obvious +from the method name. + +=back + +=head2 Inlinable Instance Operations + +=over 4 + +=item B<< $metainstance->is_inlinable >> + +This is a boolean that indicates whether or not slot access operations +can be inlined. By default it is true, but subclasses can override +this. + +=item B<< $metainstance->inline_create_instance($class_variable) >> + +This method expects a string that, I<when inlined>, will become a +class name. This would literally be something like C<'$class'>, not an +actual class name. + +It returns a snippet of code that creates a new object for the +class. This is something like C< bless {}, $class_name >. + +=item B<< $metainstance->inline_get_is_lvalue >> + +Returns whether or not C<inline_get_slot_value> is a valid lvalue. This can be +used to do extra optimizations when generating inlined methods. + +=item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >> + +=item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >> + +These methods all expect two arguments. The first is the name of a +variable, than when inlined, will represent the object +instance. Typically this will be a literal string like C<'$_[0]'>. + +The second argument is a slot name. + +The method returns a snippet of code that, when inlined, performs some +operation on the instance. + +=item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >> + +This takes the name of a variable that will, when inlined, represent the object +instance, and the name of a variable that will represent the class to rebless +into, and returns code to rebless an instance into a class. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Instance->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm new file mode 100644 index 0000000..d945bcb --- /dev/null +++ b/lib/Class/MOP/Method.pm @@ -0,0 +1,343 @@ +package Class::MOP::Method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'weaken', 'reftype', 'blessed'; + +use parent 'Class::MOP::Object'; + +# NOTE: +# if poked in the right way, +# they should act like CODE refs. +use overload '&{}' => sub { $_[0]->body }, fallback => 1; + +# construction + +sub wrap { + my ( $class, @args ) = @_; + + unshift @args, 'body' if @args % 2 == 1; + + my %params = @args; + my $code = $params{body}; + + if (blessed($code) && $code->isa(__PACKAGE__)) { + my $method = $code->clone; + delete $params{body}; + Class::MOP::class_of($class)->rebless_instance($method, %params); + return $method; + } + elsif (!ref $code || 'CODE' ne reftype($code)) { + $class->_throw_exception( WrapTakesACodeRefToBless => params => \%params, + class => $class, + code => $code + ); + } + + ($params{package_name} && $params{name}) + || $class->_throw_exception( PackageNameAndNameParamsNotGivenToWrap => params => \%params, + class => $class, + code => $code + ); + + my $self = $class->_new(\%params); + + weaken($self->{associated_metaclass}) if $self->{associated_metaclass}; + + return $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + 'body' => $params->{body}, + 'associated_metaclass' => $params->{associated_metaclass}, + 'package_name' => $params->{package_name}, + 'name' => $params->{name}, + 'original_method' => $params->{original_method}, + } => $class; +} + +## accessors + +sub associated_metaclass { shift->{'associated_metaclass'} } + +sub attach_to_class { + my ( $self, $class ) = @_; + $self->{associated_metaclass} = $class; + weaken($self->{associated_metaclass}); +} + +sub detach_from_class { + my $self = shift; + delete $self->{associated_metaclass}; +} + +sub fully_qualified_name { + my $self = shift; + $self->package_name . '::' . $self->name; +} + +sub original_method { (shift)->{'original_method'} } + +sub _set_original_method { $_[0]->{'original_method'} = $_[1] } + +# It's possible that this could cause a loop if there is a circular +# reference in here. That shouldn't ever happen in normal +# circumstances, since original method only gets set when clone is +# called. We _could_ check for such a loop, but it'd involve some sort +# of package-lexical variable, and wouldn't be terribly subclassable. +sub original_package_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_package_name + : $self->package_name; +} + +sub original_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_name + : $self->name; +} + +sub original_fully_qualified_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_fully_qualified_name + : $self->fully_qualified_name; +} + +sub execute { + my $self = shift; + $self->body->(@_); +} + +# We used to go through use Class::MOP::Class->clone_instance to do this, but +# this was awfully slow. This method may be called a number of times when +# classes are loaded (especially during Moose role application), so it is +# worth optimizing. - DR +sub clone { + my $self = shift; + + my $clone = bless { %{$self}, @_ }, blessed($self); + weaken($clone->{associated_metaclass}) if $clone->{associated_metaclass}; + + $clone->_set_original_method($self); + + return $clone; +} + +1; + +# ABSTRACT: Method Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method - Method Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Method Protocol is very small, since methods in Perl 5 are just +subroutines in a specific package. We provide a very basic +introspection interface. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method->wrap($code, %options) >> + +This is the constructor. It accepts a method body in the form of +either a code reference or a L<Class::MOP::Method> instance, followed +by a hash of options. + +The options are: + +=over 8 + +=item * name + +The method name (without a package name). This is required if C<$code> +is a coderef. + +=item * package_name + +The package name for the method. This is required if C<$code> is a +coderef. + +=item * associated_metaclass + +An optional L<Class::MOP::Class> object. This is the metaclass for the +method's class. + +=back + +=item B<< $metamethod->clone(%params) >> + +This makes a shallow clone of the method object. In particular, +subroutine reference itself is shared between all clones of a given +method. + +When a method is cloned, the original method object will be available +by calling C<original_method> on the clone. + +=item B<< $metamethod->body >> + +This returns a reference to the method's subroutine. + +=item B<< $metamethod->name >> + +This returns the method's name. + +=item B<< $metamethod->package_name >> + +This returns the method's package name. + +=item B<< $metamethod->fully_qualified_name >> + +This returns the method's fully qualified name (package name and +method name). + +=item B<< $metamethod->associated_metaclass >> + +This returns the L<Class::MOP::Class> object for the method, if one +exists. + +=item B<< $metamethod->original_method >> + +If this method object was created as a clone of some other method +object, this returns the object that was cloned. + +=item B<< $metamethod->original_name >> + +This returns the method's original name, wherever it was first +defined. + +If this method is a clone of a clone (of a clone, etc.), this method +returns the name from the I<first> method in the chain of clones. + +=item B<< $metamethod->original_package_name >> + +This returns the method's original package name, wherever it was first +defined. + +If this method is a clone of a clone (of a clone, etc.), this method +returns the package name from the I<first> method in the chain of +clones. + +=item B<< $metamethod->original_fully_qualified_name >> + +This returns the method's original fully qualified name, wherever it +was first defined. + +If this method is a clone of a clone (of a clone, etc.), this method +returns the fully qualified name from the I<first> method in the chain +of clones. + +=item B<< $metamethod->is_stub >> + +Returns true if the method is just a stub: + + sub foo; + +=item B<< $metamethod->attach_to_class($metaclass) >> + +Given a L<Class::MOP::Class> object, this method sets the associated +metaclass for the method. This will overwrite any existing associated +metaclass. + +=item B<< $metamethod->detach_from_class >> + +Removes any associated metaclass object for the method. + +=item B<< $metamethod->execute(...) >> + +This executes the method. Any arguments provided will be passed on to +the method itself. + +=item B<< Class::MOP::Method->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm new file mode 100644 index 0000000..673bfde --- /dev/null +++ b/lib/Class/MOP/Method/Accessor.pm @@ -0,0 +1,409 @@ +package Class::MOP::Method::Accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Class::MOP::Method::Generated'; + +sub new { + my $class = shift; + my %options = @_; + + (exists $options{attribute}) + || $class->_throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options, + class => $class, + ); + + (exists $options{accessor_type}) + || $class->_throw_exception( MustSupplyAnAccessorTypeToConstructWith => params => \%options, + class => $class, + ); + + (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) + || $class->_throw_exception( MustSupplyAClassMOPAttributeInstance => params => \%options, + class => $class + ); + + ($options{package_name} && $options{name}) + || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = $class->_new(\%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'attribute'}); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + associated_metaclass => $params->{associated_metaclass}, + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherit from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # defined in this class + attribute => $params->{attribute}, + accessor_type => $params->{accessor_type}, + } => $class; +} + +## accessors + +sub associated_attribute { (shift)->{'attribute'} } +sub accessor_type { (shift)->{'accessor_type'} } + +## factory + +sub _initialize_body { + my $self = shift; + + my $method_name = join "_" => ( + '_generate', + $self->accessor_type, + 'method', + ($self->is_inline ? 'inline' : ()) + ); + + $self->{'body'} = $self->$method_name(); +} + +## generators + +sub _generate_accessor_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + if (@_ >= 2) { + $attr->set_value($_[0], $_[1]); + } + $attr->get_value($_[0]); + }; +} + +sub _generate_accessor_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + 'if (@_ > 1) {', + $attr->_inline_set_value('$_[0]', '$_[1]'), + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "accessor" + ); + }; +} + +sub _generate_reader_method { + my $self = shift; + my $attr = $self->associated_attribute; + my $class = $attr->associated_class; + + return sub { + $self->_throw_exception( CannotAssignValueToReadOnlyAccessor => class_name => $class->name, + value => $_[1], + attribute => $attr + ) + if @_ > 1; + $attr->get_value($_[0]); + }; +} + +sub _generate_reader_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + my $attr_name = $attr->name; + + return try { + $self->_compile_code([ + 'sub {', + 'if (@_ > 1) {', + $self->_inline_throw_exception( CannotAssignValueToReadOnlyAccessor => + 'class_name => ref $_[0],'. + 'value => $_[1],'. + "attribute_name => '".$attr_name."'", + ) . ';', + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "reader" + ); + }; +} + +sub _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')'; +} + +sub _generate_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->set_value($_[0], $_[1]); + }; +} + +sub _generate_writer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_set_value('$_[0]', '$_[1]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "writer" + ); + }; +} + +sub _generate_predicate_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->has_value($_[0]) + }; +} + +sub _generate_predicate_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_has_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "predicate" + ); + }; +} + +sub _generate_clearer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->clear_value($_[0]) + }; +} + +sub _generate_clearer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_clear_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "clearer" + ); + }; +} + +1; + +# ABSTRACT: Method Meta Object for accessors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Accessor - Method Meta Object for accessors + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Class::MOP::Method::Accessor; + + my $reader = Class::MOP::Method::Accessor->new( + attribute => $attribute, + is_inline => 1, + accessor_type => 'reader', + ); + + $reader->body->execute($instance); # call the reader method + +=head1 DESCRIPTION + +This is a subclass of C<Class::MOP::Method> which is used by +C<Class::MOP::Attribute> to generate accessor code. It handles +generation of readers, writers, predicates and clearers. For each type +of method, it can either create a subroutine reference, or actually +inline code by generating a string and C<eval>'ing it. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Accessor->new(%options) >> + +This returns a new C<Class::MOP::Method::Accessor> based on the +C<%options> provided. + +=over 4 + +=item * attribute + +This is the C<Class::MOP::Attribute> for which accessors are being +generated. This option is required. + +=item * accessor_type + +This is a string which should be one of "reader", "writer", +"accessor", "predicate", or "clearer". This is the type of method +being generated. This option is required. + +=item * is_inline + +This indicates whether or not the accessor should be inlined. This +defaults to false. + +=item * name + +The method name (without a package name). This is required. + +=item * package_name + +The package name for the method. This is required. + +=back + +=item B<< $metamethod->accessor_type >> + +Returns the accessor type which was passed to C<new>. + +=item B<< $metamethod->is_inline >> + +Returns a boolean indicating whether or not the accessor is inlined. + +=item B<< $metamethod->associated_attribute >> + +This returns the L<Class::MOP::Attribute> object which was passed to +C<new>. + +=item B<< $metamethod->body >> + +The method itself is I<generated> when the accessor object is +constructed. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm new file mode 100644 index 0000000..c8a30ac --- /dev/null +++ b/lib/Class/MOP/Method/Constructor.pm @@ -0,0 +1,251 @@ +package Class::MOP::Method::Constructor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Class::MOP::Method::Inlined'; + +sub new { + my $class = shift; + my %options = @_; + + (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) + || $class->_throw_exception( MustSupplyAMetaclass => params => \%options, + class => $class + ) + if $options{is_inline}; + + ($options{package_name} && $options{name}) + || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = $class->_new(\%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'associated_metaclass'}); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + # associated_metaclass => $params->{associated_metaclass}, # overridden + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherited from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # inherited from Class::MOP::Inlined + _expected_method_class => $params->{_expected_method_class}, + + # defined in this subclass + options => $params->{options} || {}, + associated_metaclass => $params->{metaclass}, + }, $class; +} + +## accessors + +sub options { (shift)->{'options'} } +sub associated_metaclass { (shift)->{'associated_metaclass'} } + +## method + +sub _initialize_body { + my $self = shift; + my $method_name = '_generate_constructor_method'; + + $method_name .= '_inline' if $self->is_inline; + + $self->{'body'} = $self->$method_name; +} + +sub _eval_environment { + my $self = shift; + return $self->associated_metaclass->_eval_environment; +} + +sub _generate_constructor_method { + return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } +} + +sub _generate_constructor_method_inline { + my $self = shift; + + my $meta = $self->associated_metaclass; + + my @source = ( + 'sub {', + $meta->_inline_new_object, + '}', + ); + + warn join("\n", @source) if $self->options->{debug}; + + my $code = try { + $self->_compile_code(\@source); + } + catch { + my $source = join("\n", @source); + $self->_throw_exception( CouldNotEvalConstructor => constructor_method => $self, + source => $source, + error => $_ + ); + }; + + return $code; +} + +1; + +# ABSTRACT: Method Meta Object for constructors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Constructor - Method Meta Object for constructors + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Class::MOP::Method::Constructor; + + my $constructor = Class::MOP::Method::Constructor->new( + metaclass => $metaclass, + options => { + debug => 1, # this is all for now + }, + ); + + # calling the constructor ... + $constructor->body->execute($metaclass->name, %params); + +=head1 DESCRIPTION + +This is a subclass of L<Class::MOP::Method> which generates +constructor methods. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Constructor->new(%options) >> + +This creates a new constructor object. It accepts a hash reference of +options. + +=over 8 + +=item * metaclass + +This should be a L<Class::MOP::Class> object. It is required. + +=item * name + +The method name (without a package name). This is required. + +=item * package_name + +The package name for the method. This is required. + +=item * is_inline + +This indicates whether or not the constructor should be inlined. This +defaults to false. + +=back + +=item B<< $metamethod->is_inline >> + +Returns a boolean indicating whether or not the constructor is +inlined. + +=item B<< $metamethod->associated_metaclass >> + +This returns the L<Class::MOP::Class> object for the method. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm new file mode 100644 index 0000000..740f5f5 --- /dev/null +++ b/lib/Class/MOP/Method/Generated.pm @@ -0,0 +1,142 @@ +package Class::MOP::Method::Generated; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Eval::Closure; + +use parent 'Class::MOP::Method'; + +## accessors + +sub new { + $_[0]->_throw_exception( CannotCallAnAbstractBaseMethod => package_name => __PACKAGE__ ); +} + +sub _initialize_body { + $_[0]->_throw_exception( NoBodyToInitializeInAnAbstractBaseClass => package_name => __PACKAGE__ ); +} + +sub _generate_description { + my ( $self, $context ) = @_; + $context ||= $self->definition_context; + + my $desc = "generated method"; + my $origin = "unknown origin"; + + if (defined $context) { + if (defined $context->{description}) { + $desc = $context->{description}; + } + + if (defined $context->{file} || defined $context->{line}) { + $origin = "defined at " + . (defined $context->{file} + ? $context->{file} : "<unknown file>") + . " line " + . (defined $context->{line} + ? $context->{line} : "<unknown line>"); + } + } + + return "$desc ($origin)"; +} + +sub _compile_code { + my ( $self, @args ) = @_; + unshift @args, 'source' if @args % 2; + my %args = @args; + + my $context = delete $args{context}; + my $environment = $self->can('_eval_environment') + ? $self->_eval_environment + : {}; + + return eval_closure( + environment => $environment, + description => $self->_generate_description($context), + %args, + ); +} + +1; + +# ABSTRACT: Abstract base class for generated methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Generated - Abstract base class for generated methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a C<Class::MOP::Method> subclass which is subclassed by +C<Class::MOP::Method::Accessor> and +C<Class::MOP::Method::Constructor>. + +It is not intended to be used directly. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm new file mode 100644 index 0000000..a075200 --- /dev/null +++ b/lib/Class/MOP/Method/Inlined.pm @@ -0,0 +1,195 @@ +package Class::MOP::Method::Inlined; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Method::Generated'; + +sub _uninlined_body { + my $self = shift; + + my $super_method + = $self->associated_metaclass->find_next_method_by_name( $self->name ) + or return; + + if ( $super_method->isa(__PACKAGE__) ) { + return $super_method->_uninlined_body; + } + else { + return $super_method->body; + } +} + +sub can_be_inlined { + my $self = shift; + my $metaclass = $self->associated_metaclass; + my $class = $metaclass->name; + + # If we don't find an inherited method, this is a rather weird + # case where we have no method in the inheritance chain even + # though we're expecting one to be there + my $inherited_method + = $metaclass->find_next_method_by_name( $self->name ); + + if ( $inherited_method + && $inherited_method->isa('Class::MOP::Method::Wrapped') ) { + warn "Not inlining '" + . $self->name + . "' for $class since it " + . "has method modifiers which would be lost if it were inlined\n"; + + return 0; + } + + my $expected_class = $self->_expected_method_class + or return 1; + + # if we are shadowing a method we first verify that it is + # compatible with the definition we are replacing it with + my $expected_method = $expected_class->can( $self->name ); + + if ( ! $expected_method ) { + warn "Not inlining '" + . $self->name + . "' for $class since ${expected_class}::" + . $self->name + . " is not defined\n"; + + return 0; + } + + my $actual_method = $class->can( $self->name ) + or return 1; + + # the method is what we wanted (probably Moose::Object::new) + return 1 + if refaddr($expected_method) == refaddr($actual_method); + + # otherwise we have to check that the actual method is an inlined + # version of what we're expecting + if ( $inherited_method->isa(__PACKAGE__) ) { + if ( $inherited_method->_uninlined_body + && refaddr( $inherited_method->_uninlined_body ) + == refaddr($expected_method) ) { + return 1; + } + } + elsif ( refaddr( $inherited_method->body ) + == refaddr($expected_method) ) { + return 1; + } + + my $warning + = "Not inlining '" + . $self->name + . "' for $class since it is not" + . " inheriting the default ${expected_class}::" + . $self->name . "\n"; + + if ( $self->isa("Class::MOP::Method::Constructor") ) { + + # FIXME kludge, refactor warning generation to a method + $warning + .= "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + } + + warn $warning; + + return 0; +} + +1; + +# ABSTRACT: Method base class for methods which have been inlined + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Inlined - Method base class for methods which have been inlined + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a L<Class::MOP::Method::Generated> subclass for methods which +can be inlined. + +=head1 METHODS + +=over 4 + +=item B<< $metamethod->can_be_inlined >> + +This method returns true if the method in question can be inlined in +the associated metaclass. + +If it cannot be inlined, it spits out a warning and returns false. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Meta.pm b/lib/Class/MOP/Method/Meta.pm new file mode 100644 index 0000000..23b3567 --- /dev/null +++ b/lib/Class/MOP/Method/Meta.pm @@ -0,0 +1,169 @@ +package Class::MOP::Method::Meta; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; + +use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0; + +use parent 'Class::MOP::Method'; + +sub _is_caller_mop_internal { + my $self = shift; + my ($caller) = @_; + return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; +} + +sub _generate_meta_method { + my $method_self = shift; + my $metaclass = shift; + weaken($metaclass); + + sub { + # this will be compiled out if the env var wasn't set + if (DEBUG_NO_META) { + confess "'meta' method called by MOP internals" + # it's okay to call meta methods on metaclasses, since we + # explicitly ask for them + if !$_[0]->isa('Class::MOP::Object') + && !$_[0]->isa('Class::MOP::Mixin') + # it's okay if the test itself calls ->meta, we only care about + # if the mop internals call ->meta + && $method_self->_is_caller_mop_internal(scalar caller); + } + # we must re-initialize so that it + # works as expected in subclasses, + # since metaclass instances are + # singletons, this is not really a + # big deal anyway. + $metaclass->initialize(blessed($_[0]) || $_[0]) + }; +} + +sub wrap { + my ($class, @args) = @_; + + unshift @args, 'body' if @args % 2 == 1; + my %params = @args; + $class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params, + class => $class + ) + if $params{body}; + + my $metaclass_class = $params{associated_metaclass}->meta; + $params{body} = $class->_generate_meta_method($metaclass_class); + return $class->SUPER::wrap(%params); +} + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta + # objects are subclasses of CMOP::Method, but when we get to moose, they'll + # need to be compatible with Moose::Meta::Method, which isn't possible. the + # right solution here is to make ::Meta into a role that gets applied to + # whatever the method_metaclass happens to be and get rid of + # _meta_method_metaclass entirely, but that's not going to happen until + # we ditch cmop and get roles into the bootstrapping, so. i'm not + # maintaining the previous behavior of turning them into instances of the + # new method_metaclass because that's equally broken, and at least this way + # any issues will at least be detectable and potentially fixable. -doy + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: Method Meta Object for C<meta> methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Meta - Method Meta Object for C<meta> methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a L<Class::MOP::Method> subclass which represents C<meta> +methods installed into classes by Class::MOP. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> + +This is the constructor. It accepts a L<Class::MOP::Method> object and +a hash of options. The options accepted are identical to the ones +accepted by L<Class::MOP::Method>, except that C<body> cannot be passed +(it will be generated automatically). + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm new file mode 100644 index 0000000..6b96c5f --- /dev/null +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -0,0 +1,331 @@ +package Class::MOP::Method::Wrapped; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Method'; + +# NOTE: +# this ugly beast is the result of trying +# to micro optimize this as much as possible +# while not completely loosing maintainability. +# At this point it's "fast enough", after all +# you can't get something for nothing :) +my $_build_wrapped_method = sub { + my $modifier_table = shift; + my ($before, $after, $around) = ( + $modifier_table->{before}, + $modifier_table->{after}, + $modifier_table->{around}, + ); + if (@$before && @$after) { + $modifier_table->{cache} = sub { + for my $c (@$before) { $c->(@_) }; + my @rval; + ((defined wantarray) ? + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : + ($rval[0] = $around->{cache}->(@_))) + : + $around->{cache}->(@_)); + for my $c (@$after) { $c->(@_) }; + return unless defined wantarray; + return wantarray ? @rval : $rval[0]; + } + } + elsif (@$before && !@$after) { + $modifier_table->{cache} = sub { + for my $c (@$before) { $c->(@_) }; + return $around->{cache}->(@_); + } + } + elsif (@$after && !@$before) { + $modifier_table->{cache} = sub { + my @rval; + ((defined wantarray) ? + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : + ($rval[0] = $around->{cache}->(@_))) + : + $around->{cache}->(@_)); + for my $c (@$after) { $c->(@_) }; + return unless defined wantarray; + return wantarray ? @rval : $rval[0]; + } + } + else { + $modifier_table->{cache} = $around->{cache}; + } +}; + +sub wrap { + my ( $class, $code, %params ) = @_; + + (blessed($code) && $code->isa('Class::MOP::Method')) + || $class->_throw_exception( CanOnlyWrapBlessedCode => params => \%params, + class => $class, + code => $code + ); + + my $modifier_table = { + cache => undef, + orig => $code->body, + before => [], + after => [], + around => { + cache => $code->body, + methods => [], + }, + }; + $_build_wrapped_method->($modifier_table); + return $class->SUPER::wrap( + sub { $modifier_table->{cache}->(@_) }, + # get these from the original + # unless explicitly overridden + package_name => $params{package_name} || $code->package_name, + name => $params{name} || $code->name, + original_method => $code, + + modifier_table => $modifier_table, + ); +} + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + 'body' => $params->{body}, + 'associated_metaclass' => $params->{associated_metaclass}, + 'package_name' => $params->{package_name}, + 'name' => $params->{name}, + 'original_method' => $params->{original_method}, + + # defined in this class + 'modifier_table' => $params->{modifier_table} + } => $class; +} + +sub get_original_method { + my $code = shift; + $code->original_method; +} + +sub add_before_modifier { + my $code = shift; + my $modifier = shift; + unshift @{$code->{'modifier_table'}->{before}} => $modifier; + $_build_wrapped_method->($code->{'modifier_table'}); +} + +sub before_modifiers { + my $code = shift; + return @{$code->{'modifier_table'}->{before}}; +} + +sub add_after_modifier { + my $code = shift; + my $modifier = shift; + push @{$code->{'modifier_table'}->{after}} => $modifier; + $_build_wrapped_method->($code->{'modifier_table'}); +} + +sub after_modifiers { + my $code = shift; + return @{$code->{'modifier_table'}->{after}}; +} + +{ + # NOTE: + # this is another possible candidate for + # optimization as well. There is an overhead + # associated with the currying that, if + # eliminated might make around modifiers + # more manageable. + my $compile_around_method = sub {{ + my $f1 = pop; + return $f1 unless @_; + my $f2 = pop; + push @_, sub { $f2->( $f1, @_ ) }; + redo; + }}; + + sub add_around_modifier { + my $code = shift; + my $modifier = shift; + unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier; + $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->( + @{$code->{'modifier_table'}->{around}->{methods}}, + $code->{'modifier_table'}->{orig} + ); + $_build_wrapped_method->($code->{'modifier_table'}); + } +} + +sub around_modifiers { + my $code = shift; + return @{$code->{'modifier_table'}->{around}->{methods}}; +} + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped + # objects are subclasses of CMOP::Method, but when we get to moose, they'll + # need to be compatible with Moose::Meta::Method, which isn't possible. the + # right solution here is to make ::Wrapped into a role that gets applied to + # whatever the method_metaclass happens to be and get rid of + # wrapped_method_metaclass entirely, but that's not going to happen until + # we ditch cmop and get roles into the bootstrapping, so. i'm not + # maintaining the previous behavior of turning them into instances of the + # new method_metaclass because that's equally broken, and at least this way + # any issues will at least be detectable and potentially fixable. -doy + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: Method Meta Object for methods with before/after/around modifiers + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a L<Class::MOP::Method> subclass which implements before, +after, and around method modifiers. + +=head1 METHODS + +=head2 Construction + +=over 4 + +=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> + +This is the constructor. It accepts a L<Class::MOP::Method> object and +a hash of options. + +The options are: + +=over 8 + +=item * name + +The method name (without a package name). This will be taken from the +provided L<Class::MOP::Method> object if it is not provided. + +=item * package_name + +The package name for the method. This will be taken from the provided +L<Class::MOP::Method> object if it is not provided. + +=item * associated_metaclass + +An optional L<Class::MOP::Class> object. This is the metaclass for the +method's class. + +=back + +=item B<< $metamethod->get_original_method >> + +This returns the L<Class::MOP::Method> object that was passed to the +constructor. + +=item B<< $metamethod->add_before_modifier($code) >> + +=item B<< $metamethod->add_after_modifier($code) >> + +=item B<< $metamethod->add_around_modifier($code) >> + +These methods all take a subroutine reference and apply it as a +modifier to the original method. + +=item B<< $metamethod->before_modifiers >> + +=item B<< $metamethod->after_modifiers >> + +=item B<< $metamethod->around_modifiers >> + +These methods all return a list of subroutine references which are +acting as the specified type of modifier. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/MiniTrait.pm b/lib/Class/MOP/MiniTrait.pm new file mode 100644 index 0000000..4272901 --- /dev/null +++ b/lib/Class/MOP/MiniTrait.pm @@ -0,0 +1,113 @@ +package Class::MOP::MiniTrait; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Module::Runtime 'use_package_optimistically'; + +sub apply { + my ( $to_class, $trait ) = @_; + + for ( grep { !ref } $to_class, $trait ) { + use_package_optimistically($_); + $_ = Class::MOP::Class->initialize($_); + } + + for my $meth ( grep { $_->package_name ne 'UNIVERSAL' } $trait->get_all_methods ) { + my $meth_name = $meth->name; + next if index($meth_name, '__') == 0; # skip private subs + + if ( $to_class->find_method_by_name($meth_name) ) { + $to_class->add_around_method_modifier( $meth_name, $meth->body ); + } + else { + $to_class->add_method( $meth_name, $meth->clone ); + } + } +} + +# We can't load this with use, since it may be loaded and used from Class::MOP +# (via CMOP::Class, etc). However, if for some reason this module is loaded +# _without_ first loading Class::MOP we need to require Class::MOP so we can +# use it and CMOP::Class. +require Class::MOP; + +1; + +# ABSTRACT: Extremely limited trait application + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::MiniTrait - Extremely limited trait application + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This package provides a single function, C<apply>, which does a half-assed job +of applying a trait to a class. It exists solely for use inside Class::MOP and +L<Moose> core classes. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin.pm b/lib/Class/MOP/Mixin.pm new file mode 100644 index 0000000..578448a --- /dev/null +++ b/lib/Class/MOP/Mixin.pm @@ -0,0 +1,111 @@ +package Class::MOP::Mixin; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; +use Module::Runtime 'use_module'; + +sub meta { + require Class::MOP::Class; + Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] ); +} + +sub _throw_exception { + my ($class, $exception_type, @args_to_exception) = @_; + die use_module( "Moose::Exception::$exception_type" )->new( @args_to_exception ); +} + +1; + +# ABSTRACT: Base class for mixin classes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin - Base class for mixin classes + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class provides a few methods which are useful in all metaclasses. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Mixin->meta >> + +This returns a L<Class::MOP::Class> object for the mixin class. + +=item B<< Class::MOP::Mixin->_throw_exception >> + +Throws an exception in the L<Moose::Exception> family. This should ONLY be +used internally -- any callers outside Class::MOP::* should be using the +version in L<Moose::Util> instead. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/AttributeCore.pm b/lib/Class/MOP/Mixin/AttributeCore.pm new file mode 100644 index 0000000..9c96c6c --- /dev/null +++ b/lib/Class/MOP/Mixin/AttributeCore.pm @@ -0,0 +1,125 @@ +package Class::MOP::Mixin::AttributeCore; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Mixin'; + +sub has_accessor { defined $_[0]->{'accessor'} } +sub has_reader { defined $_[0]->{'reader'} } +sub has_writer { defined $_[0]->{'writer'} } +sub has_predicate { defined $_[0]->{'predicate'} } +sub has_clearer { defined $_[0]->{'clearer'} } +sub has_builder { defined $_[0]->{'builder'} } +sub has_init_arg { defined $_[0]->{'init_arg'} } +sub has_default { exists $_[0]->{'default'} } +sub has_initializer { defined $_[0]->{'initializer'} } +sub has_insertion_order { defined $_[0]->{'insertion_order'} } + +sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] } + +sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } +sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + +sub is_default_a_coderef { + # Uber hack because it is called from CMOP::Attribute constructor as + # $class->is_default_a_coderef(\%options) + my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'}; + + return unless ref($value); + + return ref($value) eq 'CODE' + || ( blessed($value) && $value->isa('Class::MOP::Method') ); +} + +sub default { + my ( $self, $instance ) = @_; + if ( defined $instance && $self->is_default_a_coderef ) { + # if the default is a CODE ref, then we pass in the instance and + # default can return a value based on that instance. Somewhat crude, + # but works. + return $self->{'default'}->($instance); + } + $self->{'default'}; +} + +1; + +# ABSTRACT: Core attributes shared by attribute metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::AttributeCore - Core attributes shared by attribute metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements the core attributes (aka properties) shared by all +attributes. See the L<Class::MOP::Attribute> documentation for API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/HasAttributes.pm b/lib/Class/MOP/Mixin/HasAttributes.pm new file mode 100644 index 0000000..c76377d --- /dev/null +++ b/lib/Class/MOP/Mixin/HasAttributes.pm @@ -0,0 +1,171 @@ +package Class::MOP::Mixin::HasAttributes; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Mixin'; + +sub add_attribute { + my $self = shift; + + my $attribute + = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_); + + ( $attribute->isa('Class::MOP::Mixin::AttributeCore') ) + || $self->_throw_exception( AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass => attribute => $attribute, + class_name => $self->name, + ); + + $self->_attach_attribute($attribute); + + my $attr_name = $attribute->name; + + $self->remove_attribute($attr_name) + if $self->has_attribute($attr_name); + + my $order = ( scalar keys %{ $self->_attribute_map } ); + $attribute->_set_insertion_order($order); + + $self->_attribute_map->{$attr_name} = $attribute; + + # This method is called to allow for installing accessors. Ideally, we'd + # use method overriding, but then the subclass would be responsible for + # making the attribute, which would end up with lots of code + # duplication. Even more ideally, we'd use augment/inner, but this is + # Class::MOP! + $self->_post_add_attribute($attribute) + if $self->can('_post_add_attribute'); + + return $attribute; +} + +sub has_attribute { + my ( $self, $attribute_name ) = @_; + + ( defined $attribute_name ) + || $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name ); + + exists $self->_attribute_map->{$attribute_name}; +} + +sub get_attribute { + my ( $self, $attribute_name ) = @_; + + ( defined $attribute_name ) + || $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name ); + + return $self->_attribute_map->{$attribute_name}; +} + +sub remove_attribute { + my ( $self, $attribute_name ) = @_; + + ( defined $attribute_name ) + || $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name ); + + my $removed_attribute = $self->_attribute_map->{$attribute_name}; + return unless defined $removed_attribute; + + delete $self->_attribute_map->{$attribute_name}; + + return $removed_attribute; +} + +sub get_attribute_list { + my $self = shift; + keys %{ $self->_attribute_map }; +} + +sub _restore_metaattributes_from { + my $self = shift; + my ($old_meta) = @_; + + for my $attr (sort { $a->insertion_order <=> $b->insertion_order } + map { $old_meta->get_attribute($_) } + $old_meta->get_attribute_list) { + $attr->_make_compatible_with($self->attribute_metaclass); + $self->add_attribute($attr); + } +} + +1; + +# ABSTRACT: Methods for metaclasses which have attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::HasAttributes - Methods for metaclasses which have attributes + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements methods for metaclasses which have attributes +(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for +API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm new file mode 100644 index 0000000..1a27b69 --- /dev/null +++ b/lib/Class/MOP/Mixin/HasMethods.pm @@ -0,0 +1,304 @@ +package Class::MOP::Mixin::HasMethods; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Method::Meta; + +use Scalar::Util 'blessed', 'reftype'; +use Sub::Name 'subname'; + +use parent 'Class::MOP::Mixin'; + +sub _meta_method_class { 'Class::MOP::Method::Meta' } + +sub _add_meta_method { + my $self = shift; + my ($name) = @_; + my $existing_method = $self->can('find_method_by_name') + ? $self->find_method_by_name($name) + : $self->get_method($name); + return if $existing_method + && $existing_method->isa($self->_meta_method_class); + $self->add_method( + $name => $self->_meta_method_class->wrap( + name => $name, + package_name => $self->name, + associated_metaclass => $self, + ) + ); +} + +sub wrap_method_body { + my ( $self, %args ) = @_; + + ( $args{body} && 'CODE' eq reftype $args{body} ) + || $self->_throw_exception( CodeBlockMustBeACodeRef => instance => $self, + params => \%args + ); + $self->method_metaclass->wrap( + package_name => $self->name, + %args, + ); +} + +sub add_method { + my ( $self, $method_name, $method ) = @_; + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $package_name = $self->name; + + my $body; + if ( blessed($method) && $method->isa('Class::MOP::Method') ) { + $body = $method->body; + if ( $method->package_name ne $package_name ) { + $method = $method->clone( + package_name => $package_name, + name => $method_name, + ); + } + + $method->attach_to_class($self); + } + else { + # If a raw code reference is supplied, its method object is not created. + # The method object won't be created until required. + $body = $method; + } + + $self->_method_map->{$method_name} = $method; + + my ($current_package, $current_name) = Class::MOP::get_code_info($body); + + subname($package_name . '::' . $method_name, $body) + unless defined $current_name && $current_name !~ /^__ANON__/; + + $self->add_package_symbol("&$method_name", $body); + + # we added the method to the method map too, so it's still valid + $self->update_package_cache_flag; +} + +sub _code_is_mine { + my ( $self, $code ) = @_; + + my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); + + return ( $code_package && $code_package eq $self->name ) + || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); +} + +sub has_method { + my ( $self, $method_name ) = @_; + + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $method = $self->_get_maybe_raw_method($method_name) + or return; + + return defined($self->_method_map->{$method_name} = $method); +} + +sub get_method { + my ( $self, $method_name ) = @_; + + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $method = $self->_get_maybe_raw_method($method_name) + or return; + + return $method if blessed($method) && $method->isa('Class::MOP::Method'); + + return $self->_method_map->{$method_name} = $self->wrap_method_body( + body => $method, + name => $method_name, + associated_metaclass => $self, + ); +} + +sub _get_maybe_raw_method { + my ( $self, $method_name ) = @_; + + my $map_entry = $self->_method_map->{$method_name}; + return $map_entry if defined $map_entry; + + my $code = $self->get_package_symbol("&$method_name"); + + return unless $code && $self->_code_is_mine($code); + + return $code; +} + +sub remove_method { + my ( $self, $method_name ) = @_; + + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $removed_method = delete $self->_method_map->{$method_name}; + + $self->remove_package_symbol("&$method_name"); + + $removed_method->detach_from_class + if blessed($removed_method) && $removed_method->isa('Class::MOP::Method'); + + # still valid, since we just removed the method from the map + $self->update_package_cache_flag; + + return $removed_method; +} + +sub get_method_list { + my $self = shift; + + return keys %{ $self->_full_method_map }; +} + +sub _get_local_methods { + my $self = shift; + + return values %{ $self->_full_method_map }; +} + +sub _restore_metamethods_from { + my $self = shift; + my ($old_meta) = @_; + + my $package_name = $self->name; + + # Check if Perl debugger is enabled + my $debugger_enabled = ($^P & 0x10); + my $debug_method_info; + + for my $method ($old_meta->_get_local_methods) { + my $method_name = $method->name; + + # Track DB::sub information for this method if debugger is enabled. + # This contains original method filename and line numbers. + $debug_method_info = ''; + if ($debugger_enabled) { + $debug_method_info = $DB::sub{$package_name . "::" . $method_name} + } + + $method->_make_compatible_with($self->method_metaclass); + $self->add_method($method_name => $method); + + # Restore method debug information, which can be clobbered by add_method. + # Note that we handle this here instead of in add_method, because we + # only want to preserve the original debug info in cases where we are + # restoring a method, not overwriting a method. + if ($debugger_enabled && $debug_method_info) { + $DB::sub{$package_name . "::" . $method_name} = $debug_method_info; + } + } +} + +sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } +sub update_package_cache_flag { + my $self = shift; + # NOTE: + # we can manually update the cache number + # since we are actually adding the method + # to our cache as well. This avoids us + # having to regenerate the method_map. + # - SL + $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); +} + +sub _full_method_map { + my $self = shift; + + my $pkg_gen = Class::MOP::check_package_cache_flag($self->name); + + if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) { + # forcibly reify all method map entries + $self->get_method($_) + for $self->list_all_package_symbols('CODE'); + $self->{_package_cache_flag_full} = $pkg_gen; + } + + return $self->_method_map; +} + +1; + +# ABSTRACT: Methods for metaclasses which have methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements methods for metaclasses which have methods +(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for +API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/HasOverloads.pm b/lib/Class/MOP/Mixin/HasOverloads.pm new file mode 100644 index 0000000..057551f --- /dev/null +++ b/lib/Class/MOP/Mixin/HasOverloads.pm @@ -0,0 +1,237 @@ +package Class::MOP::Mixin::HasOverloads; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Overload; + +use Devel::OverloadInfo 'overload_info'; +use Scalar::Util 'blessed'; +use Sub::Identify 'sub_name', 'stash_name'; + +use overload (); + +use parent 'Class::MOP::Mixin'; + +sub is_overloaded { + my $self = shift; + return overload::Overloaded($self->name); +} + +sub get_overload_list { + my $self = shift; + + my $info = $self->_overload_info; + return grep { $_ ne 'fallback' } keys %{$info} +} + +sub get_all_overloaded_operators { + my $self = shift; + return map { $self->_overload_for($_) } $self->get_overload_list; +} + +sub has_overloaded_operator { + my $self = shift; + my ($op) = @_; + return defined $self->_overload_info->{$op}; +} + +sub _overload_map { + $_[0]->{_overload_map} ||= {}; +} + +sub get_overloaded_operator { + my $self = shift; + my ($op) = @_; + return $self->_overload_map->{$op} ||= $self->_overload_for($op); +} + +use constant _SET_FALLBACK_EACH_TIME => $] < 5.120; + +sub add_overloaded_operator { + my $self = shift; + my ( $op, $overload ) = @_; + + my %p = ( associated_metaclass => $self ); + if ( !ref $overload ) { + %p = ( + %p, + operator => $op, + method_name => $overload, + associated_metaclass => $self, + ); + $p{method} = $self->get_method($overload) + if $self->has_method($overload); + $overload = Class::MOP::Overload->new(%p); + } + elsif ( !blessed $overload) { + $overload = Class::MOP::Overload->new( + operator => $op, + coderef => $overload, + coderef_name => sub_name($overload), + coderef_package => stash_name($overload), + %p, + ); + } + + $overload->attach_to_class($self); + $self->_overload_map->{$op} = $overload; + + my %overload = ( + $op => $overload->has_coderef + ? $overload->coderef + : $overload->method_name + ); + + # Perl 5.10 and earlier appear to have a bug where setting a new + # overloading operator wipes out the fallback value unless we pass it each + # time. + if (_SET_FALLBACK_EACH_TIME) { + $overload{fallback} = $self->get_overload_fallback_value; + } + + $self->name->overload::OVERLOAD(%overload); +} + +sub remove_overloaded_operator { + my $self = shift; + my ($op) = @_; + + delete $self->_overload_map->{$op}; + + # overload.pm provides no api for this - but the problem that makes this + # necessary has been fixed in 5.18 + $self->get_or_add_package_symbol('%OVERLOAD')->{dummy}++ + if $] < 5.017000; + + $self->remove_package_symbol('&(' . $op); +} + +sub get_overload_fallback_value { + my $self = shift; + return $self->_overload_info->{fallback}{value}; +} + +sub set_overload_fallback_value { + my $self = shift; + my $value = shift; + + $self->name->overload::OVERLOAD( fallback => $value ); +} + +# We could cache this but we'd need some logic to clear it at all the right +# times, which seems more tedious than it's worth. +sub _overload_info { + my $self = shift; + return overload_info( $self->name ) || {}; +} + +sub _overload_for { + my $self = shift; + my $op = shift; + + my $map = $self->_overload_map; + return $map->{$op} if $map->{$op}; + + my $info = $self->_overload_info->{$op}; + return unless $info; + + my %p = ( + operator => $op, + associated_metaclass => $self, + ); + + if ( $info->{code} && !$info->{method_name} ) { + $p{coderef} = $info->{code}; + @p{ 'coderef_package', 'coderef_name' } + = $info->{code_name} =~ /(.+)::([^:]+)/; + } + else { + $p{method_name} = $info->{method_name}; + if ( $self->has_method( $p{method_name} ) ) { + $p{method} = $self->get_method( $p{method_name} ); + } + } + + return $map->{$op} = Class::MOP::Overload->new(%p); +} + +1; + +# ABSTRACT: Methods for metaclasses which have overloads + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::HasOverloads - Methods for metaclasses which have overloads + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements methods for metaclasses which have overloads +(L<Class::MOP::Clas> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for +API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm new file mode 100644 index 0000000..ddc83f7 --- /dev/null +++ b/lib/Class/MOP/Module.pm @@ -0,0 +1,213 @@ +package Class::MOP::Module; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Class::MOP::Package'; + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + return bless { + # Need to quote package to avoid a problem with PPI mis-parsing this + # as a package statement. + + # from Class::MOP::Package + 'package' => $params->{package}, + namespace => \undef, + + # attributes + version => \undef, + authority => \undef + } => $class; +} + +sub version { + my $self = shift; + ${$self->get_or_add_package_symbol('$VERSION')}; +} + +sub authority { + my $self = shift; + ${$self->get_or_add_package_symbol('$AUTHORITY')}; +} + +sub identifier { + my $self = shift; + join '-' => ( + $self->name, + ($self->version || ()), + ($self->authority || ()), + ); +} + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + my $package = delete $options{package}; + my $version = delete $options{version}; + my $authority = delete $options{authority}; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_instantiate_module($version, $authority); + + return $meta; +} + +sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + $class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class, + params => \%options, + is_module => 1 + ); +} + +sub _instantiate_module { + my($self, $version, $authority) = @_; + my $package_name = $self->name; + + $self->add_package_symbol('$VERSION' => $version) + if defined $version; + $self->add_package_symbol('$AUTHORITY' => $authority) + if defined $authority; + + return; +} + +1; + +# ABSTRACT: Module Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Module - Module Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +A module is essentially a L<Class::MOP::Package> with metadata, in our +case the version and authority. + +=head1 INHERITANCE + +B<Class::MOP::Module> is a subclass of L<Class::MOP::Package>. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Module->create($package, %options) >> + +Overrides C<create> from L<Class::MOP::Package> to provide these additional +options: + +=over 4 + +=item C<version> + +A version number, to be installed in the C<$VERSION> package global variable. + +=item C<authority> + +An authority, to be installed in the C<$AUTHORITY> package global variable. + +This is a legacy field and its use is not recommended. + +=back + +=item B<< $metamodule->version >> + +This is a read-only attribute which returns the C<$VERSION> of the +package, if one exists. + +=item B<< $metamodule->authority >> + +This is a read-only attribute which returns the C<$AUTHORITY> of the +package, if one exists. + +=item B<< $metamodule->identifier >> + +This constructs a string which combines the name, version and +authority. + +=item B<< Class::MOP::Module->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Object.pm b/lib/Class/MOP/Object.pm new file mode 100644 index 0000000..a5d0896 --- /dev/null +++ b/lib/Class/MOP/Object.pm @@ -0,0 +1,200 @@ +package Class::MOP::Object; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Class::MOP::Mixin'; +use Scalar::Util 'blessed'; +use Module::Runtime; + +# introspection + +sub throw_error { + shift->_throw_exception( Legacy => message => join('', @_) ); +} + +sub _inline_throw_error { + my ( $self, $message ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::Legacy")->new(message => ' . $message. ')'; +} + +sub _new { + Class::MOP::class_of(shift)->new_object(@_); +} + +# RANT: +# Cmon, how many times have you written +# the following code while debugging: +# +# use Data::Dumper; +# warn Dumper $obj; +# +# It can get seriously annoying, so why +# not just do this ... +sub dump { + my $self = shift; + require Data::Dumper; + local $Data::Dumper::Maxdepth = shift || 1; + Data::Dumper::Dumper $self; +} + +sub _real_ref_name { + my $self = shift; + return blessed($self); +} + +sub _is_compatible_with { + my $self = shift; + my ($other_name) = @_; + + return $self->isa($other_name); +} + +sub _can_be_made_compatible_with { + my $self = shift; + return !$self->_is_compatible_with(@_) + && defined($self->_get_compatible_metaclass(@_)); +} + +sub _make_compatible_with { + my $self = shift; + my ($other_name) = @_; + + my $new_metaclass = $self->_get_compatible_metaclass($other_name); + + unless ( defined $new_metaclass ) { + $self->_throw_exception( CannotMakeMetaclassCompatible => superclass_name => $other_name, + class => $self, + ); + } + + # can't use rebless_instance here, because it might not be an actual + # subclass in the case of, e.g. moose role reconciliation + $new_metaclass->meta->_force_rebless_instance($self) + if blessed($self) ne $new_metaclass; + + return $self; +} + +sub _get_compatible_metaclass { + my $self = shift; + my ($other_name) = @_; + + return $self->_get_compatible_metaclass_by_subclassing($other_name); +} + +sub _get_compatible_metaclass_by_subclassing { + my $self = shift; + my ($other_name) = @_; + my $meta_name = blessed($self) ? $self->_real_ref_name : $self; + + if ($meta_name->isa($other_name)) { + return $meta_name; + } + elsif ($other_name->isa($meta_name)) { + return $other_name; + } + + return; +} + +1; + +# ABSTRACT: Base class for metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Object - Base class for metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a very minimal base class for metaclasses. + +=head1 METHODS + +This class provides a few methods which are useful in all metaclasses. + +=over 4 + +=item B<< Class::MOP::???->meta >> + +This returns a L<Class::MOP::Class> object. + +=item B<< $metaobject->dump($max_depth) >> + +This method uses L<Data::Dumper> to dump the object. You can pass an +optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The +default maximum depth is 1. + +=item B<< $metaclass->throw_error($message) >> + +This method calls L<Class::MOP::Mixin/_throw_exception> internally, with an object +of class L<Moose::Exception::Legacy>. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Overload.pm b/lib/Class/MOP/Overload.pm new file mode 100644 index 0000000..8ff81f5 --- /dev/null +++ b/lib/Class/MOP/Overload.pm @@ -0,0 +1,342 @@ +package Class::MOP::Overload; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use overload (); +use Scalar::Util qw( blessed weaken ); +use Try::Tiny; + +use parent 'Class::MOP::Object'; + +my %Operators = ( + map { $_ => 1 } + grep { $_ ne 'fallback' } + map { split /\s+/ } values %overload::ops +); + +sub new { + my ( $class, %params ) = @_; + + unless ( defined $params{operator} ) { + $class->_throw_exception('OverloadRequiresAnOperator'); + } + unless ( $Operators{ $params{operator} } ) { + $class->_throw_exception( + 'InvalidOverloadOperator', + operator => $params{operator}, + ); + } + + unless ( defined $params{method_name} || $params{coderef} ) { + $class->_throw_exception( + 'OverloadRequiresAMethodNameOrCoderef', + operator => $params{operator}, + ); + } + + if ( $params{coderef} ) { + unless ( defined $params{coderef_package} + && defined $params{coderef_name} ) { + + $class->_throw_exception('OverloadRequiresNamesForCoderef'); + } + } + + if ( $params{method} + && !try { $params{method}->isa('Class::MOP::Method') } ) { + + $class->_throw_exception('OverloadRequiresAMetaMethod'); + } + + if ( $params{associated_metaclass} + && !try { $params{associated_metaclass}->isa('Class::MOP::Module') } ) + { + + $class->_throw_exception('OverloadRequiresAMetaClass'); + } + + my @optional_attrs + = qw( method_name coderef coderef_package coderef_name method associated_metaclass ); + + return bless { + operator => $params{operator}, + map { defined $params{$_} ? ( $_ => $params{$_} ) : () } + @optional_attrs + }, + $class; +} + +sub operator { $_[0]->{operator} } + +sub method_name { $_[0]->{method_name} } +sub has_method_name { exists $_[0]->{method_name} } + +sub method { $_[0]->{method} } +sub has_method { exists $_[0]->{method} } + +sub coderef { $_[0]->{coderef} } +sub has_coderef { exists $_[0]->{coderef} } + +sub coderef_package { $_[0]->{coderef_package} } +sub has_coderef_package { exists $_[0]->{coderef_package} } + +sub coderef_name { $_[0]->{coderef_name} } +sub has_coderef_name { exists $_[0]->{coderef_name} } + +sub associated_metaclass { $_[0]->{associated_metaclass} } + +sub is_anonymous { + my $self = shift; + return $self->has_coderef && $self->coderef_name eq '__ANON__'; +} + +sub attach_to_class { + my ( $self, $class ) = @_; + $self->{associated_metaclass} = $class; + weaken $self->{associated_metaclass}; +} + +sub clone { + my $self = shift; + + my $clone = bless { %{$self}, @_ }, blessed($self); + weaken $clone->{associated_metaclass} if $clone->{associated_metaclass}; + + $clone->_set_original_overload($self); + + return $clone; +} + +sub original_overload { $_[0]->{original_overload} } +sub _set_original_overload { $_[0]->{original_overload} = $_[1] } + +sub _is_equal_to { + my $self = shift; + my $other = shift; + + if ( $self->has_coderef ) { + return unless $other->has_coderef; + return $self->coderef == $other->coderef; + } + else { + return $self->method_name eq $other->method_name; + } +} + +1; + +# ABSTRACT: Overload Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Overload - Overload Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + my $meta = Class->meta; + my $overload = $meta->get_overloaded_operator('+'); + + if ( $overload->has_method_name ) { + print 'Method for + is ', $overload->method_name, "\n"; + } + else { + print 'Overloading for + is implemented by ', + $overload->coderef_name, " sub\n"; + } + +=head1 DESCRIPTION + +This class provides meta information for overloading in classes and roles. + +=head1 INHERITANCE + +C<Class::MOP::Overload> is a subclass of L<Class::MOP::Object>. + +=head1 METHODS + +This class provides the following methods: + +=head2 Class::MOP::Overload->new(%options) + +This method creates a new C<Class::MOP::Overload> object. It accepts a number +of options: + +=over 4 + +=item * operator + +This is a string that matches an operator known by the L<overload> module, +such as C<""> or C<+>. This is required. + +=item * method_name + +The name of the method which implements the overloading. Note that this does +not need to actually correspond to a real method, since it's okay to declare a +not-yet-implemented overloading. + +Either this or the C<coderef> option must be passed. + +=item * method + +A L<Class::MOP::Method> object for the method which implements the +overloading. + +This is optional. + +=item * coderef + +A coderef which implements the overloading. + +Either this or the C<method_name> option must be passed. + +=item * coderef_package + +The package where the coderef was defined. + +This is required if C<coderef> is passed. + +=item * coderef_name + +The name of the coderef. This can be "__ANON__". + +This is required if C<coderef> is passed. + +=item * associated_metaclass + +A L<Class::MOP::Module> object for the associated class or role. + +This is optional. + +=back + +=head2 $overload->operator + +Returns the operator for this overload object. + +=head2 $overload->method_name + +Returns the method name that implements overloading, if it has one. + +=head2 $overload->has_method_name + +Returns true if the object has a method name. + +=head2 $overload->method + +Returns the L<Class::MOP::Method> that implements overloading, if it has one. + +=head2 $overload->has_method + +Returns true if the object has a method. + +=head2 $overload->coderef + +Returns the coderef that implements overloading, if it has one. + +=head2 $overload->has_coderef + +Returns true if the object has a coderef. + +=head2 $overload->coderef_package + +Returns the package for the coderef that implements overloading, if it has +one. + +=head2 $overload->has_coderef + +Returns true if the object has a coderef package. + +=head2 $overload->coderef_name + +Returns the sub name for the coderef that implements overloading, if it has +one. + +=head2 $overload->has_coderef_name + +Returns true if the object has a coderef name. + +=head2 $overload->is_anonymous + +Returns true if the overloading is implemented by an anonymous coderef. + +=head2 $overload->associated_metaclass + +Returns the L<Class::MOP::Module> (class or role) that is associated with the +overload object. + +=head2 $overload->clone + +Clones the overloading object, setting C<original_overload> in the process. + +=head2 $overload->original_overload + +For cloned objects, this returns the L<Class::MOP::Overload> object from which +they were cloned. This can be used to determine the source of an overloading +in a class that came from a role, for example. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm new file mode 100644 index 0000000..135ad68 --- /dev/null +++ b/lib/Class/MOP/Package.pm @@ -0,0 +1,464 @@ +package Class::MOP::Package; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; +use Devel::GlobalDestruction 'in_global_destruction'; +use Module::Runtime 'module_notional_filename'; +use Package::Stash; + +use parent 'Class::MOP::Object'; + +# creation ... + +sub initialize { + my ( $class, @args ) = @_; + + unshift @args, "package" if @args % 2; + + my %options = @args; + my $package_name = delete $options{package}; + + # we hand-construct the class until we can bootstrap it + if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) { + return $meta; + } else { + my $meta = ( ref $class || $class )->_new({ + 'package' => $package_name, + %options, + }); + Class::MOP::store_metaclass_by_name($package_name, $meta); + + Class::MOP::weaken_metaclass($package_name) if $options{weaken}; + + + return $meta; + } +} + +sub reinitialize { + my ( $class, @args ) = @_; + + unshift @args, "package" if @args % 2; + + my %options = @args; + my $package_name = delete $options{package}; + + (defined $package_name && $package_name + && (!blessed $package_name || $package_name->isa('Class::MOP::Package'))) + || $class->_throw_exception( MustPassAPackageNameOrAnExistingClassMOPPackageInstance => params => \%options, + class => $class + ); + + $package_name = $package_name->name + if blessed $package_name; + + Class::MOP::remove_metaclass_by_name($package_name); + + $class->initialize($package_name, %options); # call with first arg form for compat +} + +sub create { + my $class = shift; + my @args = @_; + + my $meta = $class->initialize(@args); + my $filename = module_notional_filename($meta->name); + $INC{$filename} = '(set by Moose)' + unless exists $INC{$filename}; + + return $meta; +} + +## ANON packages + +{ + # NOTE: + # this should be sufficient, if you have a + # use case where it is not, write a test and + # I will change it. + my $ANON_SERIAL = 0; + + my %ANON_PACKAGE_CACHE; + + # NOTE: + # we need a sufficiently annoying prefix + # this should suffice for now, this is + # used in a couple of places below, so + # need to put it up here for now. + sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' } + + sub is_anon { + my $self = shift; + no warnings 'uninitialized'; + my $prefix = $self->_anon_package_prefix; + $self->name =~ /^\Q$prefix/; + } + + sub create_anon { + my ($class, %options) = @_; + + my $cache_ok = delete $options{cache}; + $options{weaken} = !$cache_ok unless exists $options{weaken}; + + my $cache_key; + if ($cache_ok) { + $cache_key = $class->_anon_cache_key(%options); + undef $cache_ok if !defined($cache_key); + } + + if ($cache_ok) { + if (defined $ANON_PACKAGE_CACHE{$cache_key}) { + return $ANON_PACKAGE_CACHE{$cache_key}; + } + } + + my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL; + + my $meta = $class->create($package_name, %options); + + if ($cache_ok) { + $ANON_PACKAGE_CACHE{$cache_key} = $meta; + weaken($ANON_PACKAGE_CACHE{$cache_key}); + } + + return $meta; + } + + sub _anon_cache_key { + my $class = shift; + my %options = @_; + $class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class, + params => \%options, + is_module => 0 + ); + } + + sub DESTROY { + my $self = shift; + + return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated + + $self->_free_anon + if $self->is_anon; + } + + sub _free_anon { + my $self = shift; + my $name = $self->name; + + # Moose does a weird thing where it replaces the metaclass for + # class when fixing metaclass incompatibility. In that case, + # we don't want to clean out the namespace now. We can detect + # that because Moose will explicitly update the singleton + # cache in Class::MOP using store_metaclass_by_name, which + # means that the new metaclass will already exist in the cache + # by this point. + # The other options here are that $current_meta can be undef if + # remove_metaclass_by_name is called explicitly (since the hash + # entry is removed first, and then this destructor is called), + # or that $current_meta can be the same as $self, which happens + # when the metaclass goes out of scope (since the weak reference + # in the metaclass cache won't be freed until after this + # destructor runs). + my $current_meta = Class::MOP::get_metaclass_by_name($name); + return if defined($current_meta) && $current_meta ne $self; + + my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/); + + no strict 'refs'; + # clear @ISA first, to avoid a memory leak + # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708 + @{$name . '::ISA'} = (); + %{$name . '::'} = (); + delete ${$first_fragments . '::'}{$last_fragment . '::'}; + + Class::MOP::remove_metaclass_by_name($name); + + delete $INC{module_notional_filename($name)}; + } + +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # Need to quote package to avoid a problem with PPI mis-parsing this + # as a package statement. + 'package' => $params->{package}, + + # NOTE: + # because of issues with the Perl API + # to the typeglob in some versions, we + # need to just always grab a new + # reference to the hash in the accessor. + # Ideally we could just store a ref and + # it would Just Work, but oh well :\ + + namespace => \undef, + + } => $class; +} + +# Attributes + +# NOTE: +# all these attribute readers will be bootstrapped +# away in the Class::MOP bootstrap section + +sub _package_stash { + $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name) +} +sub namespace { + $_[0]->_package_stash->namespace +} + +# Class attributes + +# ... these functions have to touch the symbol table itself,.. yuk + +sub add_package_symbol { + my $self = shift; + $self->_package_stash->add_symbol(@_); +} + +sub remove_package_glob { + my $self = shift; + $self->_package_stash->remove_glob(@_); +} + +# ... these functions deal with stuff on the namespace level + +sub has_package_symbol { + my $self = shift; + $self->_package_stash->has_symbol(@_); +} + +sub get_package_symbol { + my $self = shift; + $self->_package_stash->get_symbol(@_); +} + +sub get_or_add_package_symbol { + my $self = shift; + $self->_package_stash->get_or_add_symbol(@_); +} + +sub remove_package_symbol { + my $self = shift; + $self->_package_stash->remove_symbol(@_); +} + +sub list_all_package_symbols { + my $self = shift; + $self->_package_stash->list_all_symbols(@_); +} + +sub get_all_package_symbols { + my $self = shift; + $self->_package_stash->get_all_symbols(@_); +} + +1; + +# ABSTRACT: Package Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Package - Package Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Package Protocol provides an abstraction of a Perl 5 package. A +package is basically namespace, and this module provides methods for +looking at and changing that namespace's symbol table. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Package->initialize($package_name, %options) >> + +This method creates a new C<Class::MOP::Package> instance which +represents specified package. If an existing metaclass object exists +for the package, that will be returned instead. No options are valid at the +package level. + +=item B<< Class::MOP::Package->reinitialize($package, %options) >> + +This method forcibly removes any existing metaclass for the package +before calling C<initialize>. In contrast to C<initialize>, you may +also pass an existing C<Class::MOP::Package> instance instead of just +a package name as C<$package>. + +Do not call this unless you know what you are doing. + +=item B<< Class::MOP::Package->create($package, %options) >> + +Creates a new C<Class::MOP::Package> instance which represents the specified +package, and also does some initialization of that package. Currently, this +just does the same thing as C<initialize>, but is overridden in subclasses, +such as C<Class::MOP::Class>. + +=item B<< Class::MOP::Package->create_anon(%options) >> + +Creates a new anonymous package. Valid keys for C<%options> are: + +=over 4 + +=item C<cache> + +If this will be C<true> (the default is C<false>), the instance will be cached +in C<Class::MOP>'s metaclass cache. + +=item C<weaken> + +If this is C<true> (the default C<true> when L<cache> is C<false>), the instance +stored in C<Class::MOP>'s metaclass cache will be weakened, so that the +anonymous package will be garbage collected when the returned instance goes out +of scope. + +=back + +=item B<< $metapackage->is_anon >> + +Returns true if the package is an anonymous package. + +=item B<< $metapackage->name >> + +This is returns the package's name, as passed to the constructor. + +=item B<< $metapackage->namespace >> + +This returns a hash reference to the package's symbol table. The keys +are symbol names and the values are typeglob references. + +=item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >> + +This method accepts a variable name and an optional initial value. The +C<$variable_name> must contain a leading sigil. + +This method creates the variable in the package's symbol table, and +sets it to the initial value if one was provided. + +=item B<< $metapackage->get_package_symbol($variable_name) >> + +Given a variable name, this method returns the variable as a reference +or undef if it does not exist. The C<$variable_name> must contain a +leading sigil. + +=item B<< $metapackage->get_or_add_package_symbol($variable_name) >> + +Given a variable name, this method returns the variable as a reference. +If it does not exist, a default value will be generated if possible. The +C<$variable_name> must contain a leading sigil. + +=item B<< $metapackage->has_package_symbol($variable_name) >> + +Returns true if there is a package variable defined for +C<$variable_name>. The C<$variable_name> must contain a leading sigil. + +=item B<< $metapackage->remove_package_symbol($variable_name) >> + +This will remove the package variable specified C<$variable_name>. The +C<$variable_name> must contain a leading sigil. + +=item B<< $metapackage->remove_package_glob($glob_name) >> + +Given the name of a glob, this will remove that glob from the +package's symbol table. Glob names do not include a sigil. Removing +the glob removes all variables and subroutines with the specified +name. + +=item B<< $metapackage->list_all_package_symbols($type_filter) >> + +This will list all the glob names associated with the current +package. These names do not have leading sigils. + +You can provide an optional type filter, which should be one of +'SCALAR', 'ARRAY', 'HASH', or 'CODE'. + +=item B<< $metapackage->get_all_package_symbols($type_filter) >> + +This works much like C<list_all_package_symbols>, but it returns a +hash reference. The keys are glob names and the values are references +to the value for that name. + +=item B<< Class::MOP::Package->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose.pm b/lib/Moose.pm new file mode 100644 index 0000000..d13c5f6 --- /dev/null +++ b/lib/Moose.pm @@ -0,0 +1,1277 @@ +use strict; +use warnings; +package Moose; # git description: 2.1404-10-gfb25585 +our $VERSION = '2.1405'; +our $AUTHORITY = 'cpan:STEVAN'; + +use 5.008003; + +use Scalar::Util (); +use Carp 'carp'; +use Module::Runtime 'module_notional_filename'; +use Class::Load 'is_class_loaded'; + +use Moose::Deprecated; +use Moose::Exporter; + +use Class::MOP; + +BEGIN { + die "Class::MOP version $Moose::VERSION required--this is version $Class::MOP::VERSION" + if $Moose::VERSION && $Class::MOP::VERSION ne $Moose::VERSION; +} + +use Moose::Meta::Class; +use Moose::Meta::TypeConstraint; +use Moose::Meta::TypeCoercion; +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::Util::TypeConstraints; +use Moose::Util 'throw_exception'; + +use Moose::Meta::Attribute::Native; + +sub extends { + my $meta = shift; + + unless ( @_ ) + { + throw_exception( ExtendsMissingArgs => class_name => $meta->name ); + } + # this checks the metaclass to make sure + # it is correct, sometimes it can get out + # of sync when the classes are being built + $meta->superclasses(@_); +} + +sub with { + Moose::Util::apply_all_roles(shift, @_); +} + +sub throw_error { + shift; + Class::MOP::Object->throw_error(@_); +} + +sub has { + my $meta = shift; + my $name = shift; + + my %context = Moose::Util::_caller_info; + $context{context} = 'has declaration'; + $context{type} = 'class'; + my @options = ( definition_context => \%context, @_ ); + my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ]; + $meta->add_attribute( $_, @options ) for @$attrs; +} + +sub before { + Moose::Util::add_method_modifier(shift, 'before', \@_); +} + +sub after { + Moose::Util::add_method_modifier(shift, 'after', \@_); +} + +sub around { + Moose::Util::add_method_modifier(shift, 'around', \@_); +} + +our $SUPER_PACKAGE; +our $SUPER_BODY; +our @SUPER_ARGS; + +sub super { + if (@_) { + carp 'Arguments passed to super() are ignored'; + } + + # This check avoids a recursion loop - see + # t/bugs/super_recursion.t + return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller(); + return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS); +} + +sub override { + my $meta = shift; + my ( $name, $method ) = @_; + $meta->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; + } +} + +sub augment { + my $meta = shift; + my ( $name, $method ) = @_; + $meta->add_augment_method_modifier( $name => $method ); +} + +Moose::Exporter->setup_import_methods( + with_meta => [ + qw( extends with has before after around override augment ) + ], + as_is => [ + qw( super inner ), + 'Carp::confess', + 'Scalar::Util::blessed', + ], +); + +sub init_meta { + shift; + my %args = @_; + + my $class = $args{for_class} + or throw_exception( InitMetaRequiresClass => params => \%args ); + + my $base_class = $args{base_class} || 'Moose::Object'; + my $metaclass = $args{metaclass} || 'Moose::Meta::Class'; + my $meta_name = exists $args{meta_name} ? $args{meta_name} : 'meta'; + + throw_exception( MetaclassNotLoaded => class_name => $metaclass ) + unless is_class_loaded($metaclass); + + throw_exception( MetaclassMustBeASubclassOfMooseMetaClass => class_name => $metaclass ) + unless $metaclass->isa('Moose::Meta::Class'); + + # 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") ) { + if ( $meta->isa('Moose::Meta::Role') ) { + throw_exception( MetaclassIsARoleNotASubclassOfGivenMetaclass => role_name => $class, + metaclass => $metaclass, + role => $meta + ); + } else { + throw_exception( MetaclassIsNotASubclassOfGivenMetaclass => class_name => $class, + metaclass => $metaclass, + class => $meta + ); + } + } + } else { + # no metaclass + + # now we check whether our ancestors have metaclass, and if so borrow that + my ( undef, @isa ) = @{ mro::get_linear_isa($class) }; + + foreach my $ancestor ( @isa ) { + my $ancestor_meta = Class::MOP::get_metaclass_by_name($ancestor) || next; + + my $ancestor_meta_class = $ancestor_meta->_real_ref_name; + + # if we have an ancestor metaclass that inherits $metaclass, we use + # that. This is like _fix_metaclass_incompatibility, but we can do it now. + + # the case of having an ancestry is not very common, but arises in + # e.g. Reaction + unless ( $metaclass->isa( $ancestor_meta_class ) ) { + if ( $ancestor_meta_class->isa($metaclass) ) { + $metaclass = $ancestor_meta_class; + } + } + } + + $meta = $metaclass->initialize($class); + my $filename = module_notional_filename($meta->name); + $INC{$filename} = '(set by Moose)' + unless exists $INC{$filename}; + } + + if (defined $meta_name) { + # also check for inherited non moose 'meta' method? + my $existing = $meta->get_method($meta_name); + if ($existing && !$existing->isa('Class::MOP::Method::Meta')) { + Carp::cluck "Moose is overwriting an existing method named " + . "$meta_name in class $class with a method " + . "which returns the class's metaclass. If this is " + . "actually what you want, you should remove the " + . "existing method, otherwise, you should rename or " + . "disable this generated method using the " + . "'-meta_name' option to 'use Moose'."; + } + $meta->_add_meta_method($meta_name); + } + + # 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 + +$_->make_immutable( + inline_constructor => 1, + constructor_name => "_new", + # these are Class::MOP accessors, so they need inlining + inline_accessors => 1 + ) for grep { $_->is_mutable } + map { $_->meta } + qw( + Moose::Meta::Attribute + Moose::Meta::Class + Moose::Meta::Instance + + Moose::Meta::TypeCoercion + Moose::Meta::TypeCoercion::Union + + Moose::Meta::Method + Moose::Meta::Method::Constructor + Moose::Meta::Method::Destructor + Moose::Meta::Method::Overridden + Moose::Meta::Method::Augmented + + Moose::Meta::Role + Moose::Meta::Role::Attribute + Moose::Meta::Role::Method + Moose::Meta::Role::Method::Required + Moose::Meta::Role::Method::Conflicting + + 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 +); + +$_->make_immutable( + inline_constructor => 0, + constructor_name => undef, + # these are Class::MOP accessors, so they need inlining + inline_accessors => 1 + ) for grep { $_->is_mutable } + map { $_->meta } + qw( + Moose::Meta::Method::Accessor + Moose::Meta::Method::Delegation + Moose::Meta::Mixin::AttributeCore +); + +1; + +# ABSTRACT: A postmodern object system for Perl 5 + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose - A postmodern object system for Perl 5 + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Point; + use Moose; # automatically turns on strict and warnings + + has 'x' => (is => 'rw', isa => 'Int'); + has 'y' => (is => 'rw', isa => 'Int'); + + sub clear { + my $self = shift; + $self->x(0); + $self->y(0); + } + + package Point3D; + use Moose; + + extends 'Point'; + + has 'z' => (is => 'rw', isa => 'Int'); + + after 'clear' => sub { + my $self = shift; + $self->z(0); + }; + +=head1 DESCRIPTION + +Moose is an extension of the Perl 5 object system. + +The main goal of Moose is to make Perl 5 Object Oriented programming +easier, more consistent, and less tedious. With Moose you can think +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? + +If you're new to Moose, the best place to start is the +L<Moose::Manual> docs, followed by the L<Moose::Cookbook>. The intro +will show you what Moose is, and how it makes Perl 5 OO better. + +The cookbook recipes on Moose basics will get you up to speed with +many of Moose's features quickly. Once you have an idea of what Moose +can do, you can use the API documentation to get more detail on +features which interest you. + +=head2 Moose Extensions + +The C<MooseX::> namespace is the official place to find Moose extensions. +These extensions can be found on the CPAN. The easiest way to find them +is to search for them (L<https://metacpan.org/search?q=MooseX::>), +or to examine L<Task::Moose> which aims to keep an up-to-date, easily +installable list of Moose extensions. + +=head1 TRANSLATIONS + +Much of the Moose documentation has been translated into other languages. + +=over 4 + +=item Japanese + +Japanese docs can be found at +L<http://perldoc.perlassociation.org/pod/Moose-Doc-JA/index.html>. The +source POD files can be found in GitHub: +L<http://github.com/jpa/Moose-Doc-JA> + +=back + +=head1 BUILDING CLASSES WITH MOOSE + +Moose makes every attempt to provide as much convenience as possible during +class construction/definition, but still stay out of your way if you want it +to. Here are a few items to note when building classes with Moose. + +When you C<use Moose>, Moose will set the class's parent class to +L<Moose::Object>, I<unless> the class using Moose already has a parent +class. In addition, specifying a parent with C<extends> will change the parent +class. + +Moose will also manage all attributes (including inherited ones) that are +defined with C<has>. And (assuming you call C<new>, which is inherited from +L<Moose::Object>) this includes properly initializing all instance slots, +setting defaults where appropriate, and performing any type constraint checking +or coercion. + +=head1 PROVIDED METHODS + +Moose provides a number of methods to all your classes, mostly through the +inheritance of L<Moose::Object>. There is however, one exception. By default, +Moose will install a method named C<meta> in any class which uses +C<Moose>. This method returns the current class's metaclass. + +If you'd like to rename this method, you can do so by passing the +C<-meta_name> option when using Moose: + + use Moose -meta_name => 'my_meta'; + +However, the L<Moose::Object> class I<also> provides a method named C<meta> +which does the same thing. If your class inherits from L<Moose::Object> (which +is the default), then you will still have a C<meta> method. However, if your +class inherits from a parent which provides a C<meta> method of its own, your +class will inherit that instead. + +If you'd like for Moose to not install a meta method at all, you can pass +C<undef> as the C<-meta_name> option: + + use Moose -meta_name => undef; + +Again, you will still inherit C<meta> from L<Moose::Object> in this case. + +=head1 EXPORTED FUNCTIONS + +Moose will export a number of functions into the class's namespace which +may then be used to set up the class. These functions all work directly +on the current class. + +=over 4 + +=item B<extends (@superclasses)> + +This function will set the superclass(es) for the current class. If the parent +classes are not yet loaded, then C<extends> tries to load them. + +This approach is recommended instead of C<use L<base>>/C<use L<parent>>, because +C<use base> actually C<push>es onto the class's C<@ISA>, whereas C<extends> will +replace it. This is important to ensure that classes which do not have +superclasses still properly inherit from L<Moose::Object>. + +Each superclass can be followed by a hash reference with options. Currently, +only L<-version|Class::MOP/Class Loading Options> is recognized: + + extends 'My::Parent' => { -version => 0.01 }, + 'My::OtherParent' => { -version => 0.03 }; + +An exception will be thrown if the version requirements are not +satisfied. + +=item B<with (@roles)> + +This will apply a given set of C<@roles> to the local class. + +Like with C<extends>, each specified role can be followed by a hash +reference with a L<-version|Class::MOP/Class Loading Options> option: + + with 'My::Role' => { -version => 0.32 }, + 'My::Otherrole' => { -version => 0.23 }; + +The specified version requirements must be satisfied, otherwise an +exception will be thrown. + +If your role takes options or arguments, they can be passed along in the +hash reference as well. + +=item B<has $name|@$names =E<gt> %options> + +This will install an attribute of a given C<$name> into the current class. If +the first parameter is an array reference, it will create an attribute for +every C<$name> in the list. The C<%options> will be passed to the constructor +for L<Moose::Meta::Attribute> (which inherits from L<Class::MOP::Attribute>), +so the full documentation for the valid options can be found there. These are +the most commonly used options: + +=over 4 + +=item I<is =E<gt> 'rw'|'ro'> + +The I<is> option accepts either I<rw> (for read/write) or I<ro> (for read +only). These will create either a read/write accessor or a read-only +accessor respectively, using the same name as the C<$name> of the attribute. + +If you need more control over how your accessors are named, you can +use the L<reader|Class::MOP::Attribute/reader>, +L<writer|Class::MOP::Attribute/writer> and +L<accessor|Class::MOP::Attribute/accessor> options inherited from +L<Class::MOP::Attribute>, however if you use those, you won't need the +I<is> option. + +=item I<isa =E<gt> $type_name> + +The I<isa> option uses Moose's type constraint facilities to set up runtime +type checking for this attribute. Moose will perform the checks during class +construction, and within any accessors. The C<$type_name> argument must be a +string. The string may be either a class name or a type defined using +Moose's type definition features. (Refer to L<Moose::Util::TypeConstraints> +for information on how to define a new type, and how to retrieve type meta-data). + +=item I<coerce =E<gt> (1|0)> + +This will attempt to use coercion with the supplied type constraint to change +the value passed into any accessors or constructors. You B<must> supply a type +constraint, and that type constraint B<must> define a coercion. See +L<Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion> for an example. + +=item I<does =E<gt> $role_name> + +This will accept the name of a role which the value stored in this attribute +is expected to have consumed. + +=item I<required =E<gt> (1|0)> + +This marks the attribute as being required. This means a value must be +supplied during class construction, I<or> the attribute must be lazy +and have either a default or a builder. Note that c<required> does not +say anything about the attribute's value, which can be C<undef>. + +=item I<weak_ref =E<gt> (1|0)> + +This will tell the class to store the value of this attribute as a weakened +reference. If an attribute is a weakened reference, it B<cannot> also be +coerced. Note that when a weak ref expires, the attribute's value becomes +undefined, and is still considered to be set for purposes of predicate, +default, etc. + +=item I<lazy =E<gt> (1|0)> + +This will tell the class to not create this slot until absolutely necessary. +If an attribute is marked as lazy it B<must> have a default or builder +supplied. + +=item I<trigger =E<gt> $code> + +The I<trigger> option is a CODE reference which will be called after +the value of the attribute is set. The CODE ref is passed the +instance itself, the updated value, and the original value if the +attribute was already set. + +You B<can> have a trigger on a read-only attribute. + +B<NOTE:> Triggers will only fire when you B<assign> to the attribute, +either in the constructor, or using the writer. Default and built values will +B<not> cause the trigger to be fired. + +=item I<handles =E<gt> ARRAY | HASH | REGEXP | ROLE | ROLETYPE | DUCKTYPE | CODE> + +The I<handles> option provides Moose classes with automated delegation features. +This is a pretty complex and powerful option. It accepts many different option +formats, each with its own benefits and drawbacks. + +B<NOTE:> The class being delegated to does not need to be a Moose based class, +which is why this feature is especially useful when wrapping non-Moose classes. + +All I<handles> option formats share the following traits: + +You cannot override a locally defined method with a delegated method; an +exception will be thrown if you try. That is to say, if you define C<foo> in +your class, you cannot override it with a delegated C<foo>. This is almost never +something you would want to do, and if it is, you should do it by hand and not +use Moose. + +You cannot override any of the methods found in Moose::Object, or the C<BUILD> +and C<DEMOLISH> methods. These will not throw an exception, but will silently +move on to the next method in the list. My reasoning for this is that you would +almost never want to do this, since it usually breaks your class. As with +overriding locally defined methods, if you do want to do this, you should do it +manually, not with Moose. + +You do not I<need> to have a reader (or accessor) for the attribute in order +to delegate to it. Moose will create a means of accessing the value for you, +however this will be several times B<less> efficient then if you had given +the attribute a reader (or accessor) to use. + +Below is the documentation for each option format: + +=over 4 + +=item C<ARRAY> + +This is the most common usage for I<handles>. You basically pass a list of +method names to be delegated, and Moose will install a delegation method +for each one. + +=item C<HASH> + +This is the second most common usage for I<handles>. Instead of a list of +method names, you pass a HASH ref where each key is the method name you +want installed locally, and its value is the name of the original method +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): + + package Tree; + use Moose; + + has 'node' => (is => 'rw', isa => 'Any'); + + has 'children' => ( + is => 'ro', + isa => 'ArrayRef', + default => sub { [] } + ); + + has 'parent' => ( + is => 'rw', + isa => 'Tree', + weak_ref => 1, + handles => { + parent_node => 'node', + siblings => 'children', + } + ); + +In this example, the Tree package gets C<parent_node> and C<siblings> methods, +which delegate to the C<node> and C<children> methods (respectively) of the Tree +instance stored in the C<parent> slot. + +You may also use an array reference to curry arguments to the original method. + + has 'thing' => ( + ... + handles => { set_foo => [ set => 'foo' ] }, + ); + + # $self->set_foo(...) calls $self->thing->set('foo', ...) + +The first element of the array reference is the original method name, and the +rest is a list of curried arguments. + +=item C<REGEXP> + +The regexp option works very similar to the ARRAY option, except that it builds +the list of methods for you. It starts by collecting all possible methods of the +class being delegated to, then filters that list using the regexp supplied here. + +B<NOTE:> An I<isa> option is required when using the regexp option format. This +is so that we can determine (at compile time) the method list from the class. +Without an I<isa> this is just not possible. + +=item C<ROLE> or C<ROLETYPE> + +With the role option, you specify the name of a role or a +L<role type|Moose::Meta::TypeConstraint::Role> whose "interface" then becomes +the list of methods to handle. The "interface" can be defined as; the methods +of the role and any required methods of the role. It should be noted that this +does B<not> include any method modifiers or generated attribute methods (which +is consistent with role composition). + +=item C<DUCKTYPE> + +With the duck type option, you pass a duck type object whose "interface" then +becomes the list of methods to handle. The "interface" can be defined as the +list of methods passed to C<duck_type> to create a duck type object. For more +information on C<duck_type> please check +L<Moose::Util::TypeConstraints>. + +=item C<CODE> + +This is the option to use when you really want to do something funky. You should +only use it if you really know what you are doing, as it involves manual +metaclass twiddling. + +This takes a code reference, which should expect two arguments. The first is the +attribute meta-object this I<handles> is attached to. The second is the +metaclass of the class being delegated to. It expects you to return a hash (not +a HASH ref) of the methods you want mapped. + +=back + +=item I<traits =E<gt> [ @role_names ]> + +This tells Moose to take the list of C<@role_names> and apply them to the +attribute meta-object. Custom attribute metaclass traits 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<Metaclass and Trait Name Resolution> for details on how a trait name is +resolved to a role name. + +Also see L<Moose::Cookbook::Meta::Labeled_AttributeTrait> for a metaclass +trait example. + +=item I<builder> => Str + +The value of this key is the name of the method that will be called to obtain +the value used to initialize the attribute. See the L<builder option docs in +Class::MOP::Attribute|Class::MOP::Attribute/builder> and/or +L<Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild> for more +information. + +=item I<default> => SCALAR | CODE + +The value of this key is the default value which will initialize the attribute. + +NOTE: If the value is a simple scalar (string or number), then it can +be just passed as is. However, if you wish to initialize it with a +HASH or ARRAY ref, then you need to wrap that inside a CODE reference. +See the L<default option docs in +Class::MOP::Attribute|Class::MOP::Attribute/default> for more +information. + +=item I<clearer> => Str + +Creates a method allowing you to clear the value. See the L<clearer option +docs in Class::MOP::Attribute|Class::MOP::Attribute/clearer> for more +information. + +=item I<predicate> => Str + +Creates a method to perform a basic test to see if a value has been set in the +attribute. See the L<predicate option docs in +Class::MOP::Attribute|Class::MOP::Attribute/predicate> for more information. + +Note that the predicate will return true even for a C<weak_ref> attribute +whose value has expired. + +=item I<documentation> => $string + +An arbitrary string that can be retrieved later by calling C<< +$attr->documentation >>. + +=back + +=item B<has +$name =E<gt> %options> + +This is variation on the normal attribute creator C<has> which allows you to +clone and extend an attribute from a superclass or from a role. Here is an +example of the superclass usage: + + package Foo; + use Moose; + + has 'message' => ( + is => 'rw', + isa => 'Str', + default => 'Hello, I am a Foo' + ); + + package My::Foo; + use Moose; + + extends 'Foo'; + + has '+message' => (default => 'Hello I am My::Foo'); + +What is happening here is that B<My::Foo> is cloning the C<message> attribute +from its parent class B<Foo>, retaining the C<is =E<gt> 'rw'> and C<isa =E<gt> +'Str'> characteristics, but changing the value in C<default>. + +Here is another example, but within the context of a role: + + 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 +and altering it within the bounds of this feature. + +Note that you can only extend an attribute from either a superclass or a role, +you cannot extend an attribute in a role that composes over an attribute from +another role. + +Aside from where the attributes come from (one from superclass, the other +from a role), this feature works exactly the same. This feature is restricted +somewhat, so as to try and force at least I<some> sanity into it. Most options work the same, but there are some exceptions: + +=over 4 + +=item I<reader> + +=item I<writer> + +=item I<accessor> + +=item I<clearer> + +=item I<predicate> + +These options can be added, but cannot override a superclass definition. + +=item I<traits> + +You are allowed to B<add> additional traits to the C<traits> definition. +These traits will be composed into the attribute, but preexisting traits +B<are not> overridden, or removed. + +=back + +=item B<before $name|@names|\@names|qr/.../ =E<gt> sub { ... }> + +=item B<after $name|@names|\@names|qr/.../ =E<gt> sub { ... }> + +=item B<around $name|@names|\@names|qr/.../ =E<gt> sub { ... }> + +These three items are syntactic sugar for the before, after, and around method +modifier features that L<Class::MOP> provides. More information on these may be +found in L<Moose::Manual::MethodModifiers> and the +L<Class::MOP::Class documentation|Class::MOP::Class/"Method Modifiers">. + +=item B<override ($name, &sub)> + +An C<override> method is a way of explicitly saying "I am overriding this +method from my superclass". You can call C<super> within this method, and +it will work as expected. The same thing I<can> be accomplished with a normal +method call and the C<SUPER::> pseudo-package; it is really your choice. + +=item B<super> + +The keyword C<super> is a no-op when called outside of an C<override> method. In +the context of an C<override> method, it will call the next most appropriate +superclass method with the same arguments as the original method. + +=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::Basics::Document_AugmentAndInner>. + +=item B<inner> + +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::Basics::Document_AugmentAndInner>. + +=item B<blessed> + +This is the C<Scalar::Util::blessed> function. It is highly recommended that +this is used instead of C<ref> anywhere you need to test for an object's class +name. + +=item B<confess> + +This is the C<Carp::confess> function, and exported here for historical +reasons. + +=back + +=head1 METACLASS + +When you use Moose, you can 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<Metaclass and Trait Name Resolution> for more +details. + +=head2 Metaclass and 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 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. + +The lookup method for metaclasses is the same, except that it looks +for a class matching B<Moose::Meta::$type::Custom::$metaclass_name>. + +If all this is confusing, take a look at +L<Moose::Cookbook::Meta::Labeled_AttributeTrait>, which demonstrates how to +create an attribute trait. + +=head1 UNIMPORTING FUNCTIONS + +=head2 B<unimport> + +Moose offers a way to remove the keywords it exports, through the C<unimport> +method. You simply have to say C<no Moose> at the bottom of your code for this +to work. Here is an example: + + package Person; + use Moose; + + has 'first_name' => (is => 'rw', isa => 'Str'); + has 'last_name' => (is => 'rw', isa => 'Str'); + + sub full_name { + my $self = shift; + $self->first_name . ' ' . $self->last_name + } + + no Moose; # keywords are removed from the Person package + +=head1 EXTENDING AND EMBEDDING MOOSE + +To learn more about extending Moose, we recommend checking out the +"Extending" recipes in the L<Moose::Cookbook>, starting with +L<Moose::Cookbook::Extending::ExtensionOverview>, which provides an overview of +all the different ways you might extend Moose. L<Moose::Exporter> and +L<Moose::Util::MetaRole> are the modules which provide the majority of the +extension functionality, so reading their documentation should also be helpful. + +=head2 The MooseX:: namespace + +Generally if you're writing an extension I<for> Moose itself you'll want +to put your extension in the C<MooseX::> namespace. This namespace is +specifically for extensions that make Moose better or different in some +fundamental way. It is traditionally B<not> for a package that just happens +to use Moose. This namespace follows from the examples of the C<LWPx::> +and C<DBIx::> namespaces that perform the same function for C<LWP> and C<DBI> +respectively. + +=head1 METACLASS COMPATIBILITY AND MOOSE + +Metaclass compatibility is a thorny subject. You should start by +reading the "About Metaclass compatibility" section in the +L<Class::MOP> docs. + +Moose will attempt to resolve a few cases of metaclass incompatibility +when you set the superclasses for a class, in addition to the cases that +L<Class::MOP> handles. + +Moose tries to determine if the metaclasses only "differ by roles". This +means that the parent and child's metaclass share a common ancestor in +their respective hierarchies, and that the subclasses under the common +ancestor are only different because of role applications. This case is +actually fairly common when you mix and match various C<MooseX::*> +modules, many of which apply roles to the metaclass. + +If the parent and child do differ by roles, Moose replaces the +metaclass in the child with a newly created metaclass. This metaclass +is a subclass of the parent's metaclass which does all of the roles that +the child's metaclass did before being replaced. Effectively, this +means the new metaclass does all of the roles done by both the +parent's and child's original metaclasses. + +Ultimately, this is all transparent to you except in the case of an +unresolvable conflict. + +=head1 CAVEATS + +=over 4 + +=item * + +It should be noted that C<super> and C<inner> B<cannot> be used in the same +method. However, they may be combined within the same class hierarchy; see +F<t/basics/override_augment_inner_super.t> for an example. + +The reason for this is that C<super> is only valid within a method +with the C<override> modifier, and C<inner> will never be valid within an +C<override> method. In fact, C<augment> will skip over any C<override> methods +when searching for its appropriate C<inner>. + +This might seem like a restriction, but I am of the opinion that keeping these +two features separate (yet interoperable) actually makes them easy to use, since +their behavior is then easier to predict. Time will tell whether I am right or +not (UPDATE: so far so good). + +=back + +=head1 GETTING HELP + +We offer both a mailing list and a very active IRC channel. + +The mailing list is L<mailto:moose@perl.org>. You must be subscribed to send +a message. To subscribe, send an empty message to +L<mailto:moose-subscribe@perl.org> + +You can also visit us at C<#moose> on L<irc://irc.perl.org/#moose> +This channel is quite active, and questions at all levels (on Moose-related +topics ;) are welcome. + +=head1 WHAT DOES MOOSE STAND FOR? + +Moose doesn't stand for one thing in particular, however, if you want, here +are a few of our favorites. Feel free to contribute more! + +=over 4 + +=item * Make Other Object Systems Envious + +=item * Makes Object Orientation So Easy + +=item * Makes Object Orientation Spiffy- Er (sorry ingy) + +=item * Most Other Object Systems Emasculate + +=item * Moose Often Ovulate Sorta Early + +=item * Moose Offers Often Super Extensions + +=item * Meta Object Obligates Salivary Excitation + +=item * Meta Object Orientation Syntax Extensions + +=item * Moo, Only Overengineered, Slow, and Execrable (blame rjbs!) + +=item * Massive Object-Oriented Stacktrace Emitter + +=back + +=head1 ACKNOWLEDGEMENTS + +=over 4 + +=item I blame Sam Vilain for introducing me to the insanity that is meta-models. + +=item I blame Audrey Tang for then encouraging my meta-model habit in #perl6. + +=item Without Yuval "nothingmuch" Kogman this module would not be possible, +and it certainly wouldn't have this name ;P + +=item The basis of the TypeContraints module was Rob Kinyon's idea +originally, I just ran with it. + +=item Thanks to mst & chansen and the whole #moose posse for all the +early ideas/feature-requests/encouragement/bug-finding. + +=item Thanks to David "Theory" Wheeler for meta-discussions and spelling fixes. + +=back + +=head1 SEE ALSO + +=over 4 + +=item L<http://moose.perl.org/> + +This is the official web home of Moose. It contains links to our public git +repository, as well as links to a number of talks and articles on Moose and +Moose related technologies. + +=item the L<Moose manual|Moose::Manual> + +This is an introduction to Moose which covers most of the basics. + +=item Modern Perl, by chromatic + +This is an introduction to modern Perl programming, which includes a section on +Moose. It is available in print and as a free download from +L<http://onyxneon.com/books/modern_perl/>. + +=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 Several Moose extension modules in the C<MooseX::> namespace. + +See L<https://metacpan.org/search?q=MooseX::> for extensions. + +=back + +=head2 Books + +=over 4 + +=item The Art of the MetaObject Protocol + +I mention this in the L<Class::MOP> docs too, as this book was critical in +the development of both modules and is highly recommended. + +=back + +=head2 Papers + +=over 4 + +=item L<http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf> + +This paper (suggested by lbr on #moose) was what lead to the implementation +of the C<super>/C<override> and C<inner>/C<augment> features. If you really +want to understand them, I suggest you read this. + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. + +Please report any bugs to C<bug-moose@rt.cpan.org>, or through the web +interface at L<http://rt.cpan.org>. You can also submit a C<TODO> test as a +pull request at L<https://github.com/moose/Moose>. + +You can also discuss feature requests or possible bugs on the Moose mailing +list (moose@perl.org) or on IRC at L<irc://irc.perl.org/#moose>. + +=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 (moose@perl.org) or join us on IRC at +L<irc://irc.perl.org/#moose> to discuss. The +L<Moose::Manual::Contributing> has more detail about how and when you +can contribute. + +=head1 CABAL + +There are only a few people with the rights to release a new version +of Moose. The Moose Cabal are the people to go to with questions regarding +the wider purview of Moose. They help maintain not just the code +but the community as well. See the list below under C<AUTHORS>. + +=head1 CONTRIBUTORS + +Moose is a community project, and as such, involves the work of many, many +members of the community beyond just the members in the cabal. In particular: + +Dave (autarch) Rolsky wrote most of the documentation in L<Moose::Manual>. + +John (jgoulah) Goulah wrote L<Moose::Cookbook::Snack::Keywords>. + +Jess (castaway) Robinson wrote L<Moose::Cookbook::Snack::Types>. + +Aran (bluefeet) Clary Deltac wrote +L<Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion>. + +Anders (Debolaz) Nor Berle contributed L<Test::Moose> and L<Moose::Util>. + +Also, the code in L<Moose::Meta::Attribute::Native> is based on code from the +L<MooseX::AttributeHelpers> distribution, which had contributions from: + +Chris (perigrin) Prather + +Cory (gphat) Watson + +Evan Carroll + +Florian (rafl) Ragwitz + +Jason May + +Jay Hannah + +Jesse (doy) Luehrs + +Paul (frodwith) Driver + +Robert (rlb3) Boone + +Robert Buels + +Robert (phaylon) Sedlacek + +Shawn (Sartak) Moore + +Stevan Little + +Tom (dec) Lanyon + +Yuval Kogman + +Finally, these people also contributed various tests, bug fixes, +documentation, and features to the Moose codebase: + +Aankhen + +Adam (Alias) Kennedy + +Christian (chansen) Hansen + +Cory (gphat) Watson + +Dylan Hardison (doc fixes) + +Eric (ewilhelm) Wilhelm + +Evan Carroll + +Guillermo (groditi) Roditi + +Jason May + +Jay Hannah + +Jonathan (jrockway) Rockway + +Matt (mst) Trout + +Nathan (kolibrie) Gray + +Paul (frodwith) Driver + +Piotr (dexter) Roszatycki + +Robert Buels + +Robert (phaylon) Sedlacek + +Robert (rlb3) Boone + +Sam (mugwump) Vilain + +Scott (konobi) McWhirter + +Shlomi (rindolf) Fish + +Tom (dec) Lanyon + +Wallace (wreis) Reis + +... and many other #moose folks + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Conflicts.pm b/lib/Moose/Conflicts.pm new file mode 100644 index 0000000..612dc9c --- /dev/null +++ b/lib/Moose/Conflicts.pm @@ -0,0 +1,113 @@ +package # hide from PAUSE + Moose::Conflicts; + +use strict; +use warnings; + +# this module was generated with Dist::Zilla::Plugin::Conflicts 0.17 + +use Dist::CheckConflicts + -dist => 'Moose', + -conflicts => { + 'Catalyst' => '5.90049999', + 'Config::MVP' => '2.200004', + 'Devel::REPL' => '1.003020', + 'Dist::Zilla::Plugin::Git' => '2.016', + 'Fey' => '0.36', + 'Fey::ORM' => '0.42', + 'File::ChangeNotify' => '0.15', + 'HTTP::Throwable' => '0.017', + 'KiokuDB' => '0.51', + 'Markdent' => '0.16', + 'Mason' => '2.18', + 'MooseX::ABC' => '0.05', + 'MooseX::Aliases' => '0.08', + 'MooseX::AlwaysCoerce' => '0.13', + 'MooseX::App' => '1.22', + 'MooseX::Attribute::Deflator' => '2.1.7', + 'MooseX::Attribute::Dependent' => '1.1.0', + 'MooseX::Attribute::Prototype' => '0.10', + 'MooseX::AttributeHelpers' => '0.22', + 'MooseX::AttributeIndexes' => '1.0.0', + 'MooseX::AttributeInflate' => '0.02', + 'MooseX::CascadeClearing' => '0.03', + 'MooseX::ClassAttribute' => '0.26', + 'MooseX::Constructor::AllErrors' => '0.021', + 'MooseX::Declare' => '0.35', + 'MooseX::FollowPBP' => '0.02', + 'MooseX::Getopt' => '0.56', + 'MooseX::InstanceTracking' => '0.04', + 'MooseX::LazyRequire' => '0.06', + 'MooseX::Meta::Attribute::Index' => '0.04', + 'MooseX::Meta::Attribute::Lvalue' => '0.05', + 'MooseX::Method::Signatures' => '0.44', + 'MooseX::MethodAttributes' => '0.22', + 'MooseX::NonMoose' => '0.24', + 'MooseX::Object::Pluggable' => '0.0011', + 'MooseX::POE' => '0.214', + 'MooseX::Params::Validate' => '0.05', + 'MooseX::PrivateSetters' => '0.03', + 'MooseX::Role::Cmd' => '0.06', + 'MooseX::Role::Parameterized' => '1.00', + 'MooseX::Role::WithOverloading' => '0.14', + 'MooseX::Runnable' => '0.03', + 'MooseX::Scaffold' => '0.05', + 'MooseX::SemiAffordanceAccessor' => '0.05', + 'MooseX::SetOnce' => '0.100473', + 'MooseX::Singleton' => '0.25', + 'MooseX::SlurpyConstructor' => '1.1', + 'MooseX::Storage' => '0.42', + 'MooseX::StrictConstructor' => '0.12', + 'MooseX::Traits' => '0.11', + 'MooseX::Types' => '0.19', + 'MooseX::Types::Parameterizable' => '0.05', + 'MooseX::Types::Set::Object' => '0.03', + 'MooseX::Types::Signal' => '1.101930', + 'MooseX::UndefTolerant' => '0.11', + 'PRANG' => '0.14', + 'Pod::Elemental' => '0.093280', + 'Pod::Weaver' => '3.101638', + 'Reaction' => '0.002003', + 'Test::Able' => '0.10', + 'Test::CleanNamespaces' => '0.03', + 'Test::Moose::More' => '0.022', + 'Test::TempDir' => '0.05', + 'Throwable' => '0.102080', + 'namespace::autoclean' => '0.08', + }, + -also => [ qw( + Carp + Class::Load + Class::Load::XS + Data::OptList + Devel::GlobalDestruction + Devel::OverloadInfo + Devel::StackTrace + Dist::CheckConflicts + Eval::Closure + List::MoreUtils + List::Util + MRO::Compat + Module::Runtime + Module::Runtime::Conflicts + Package::DeprecationManager + Package::Stash + Package::Stash::XS + Params::Util + Scalar::Util + Sub::Exporter + Sub::Identify + Sub::Name + Task::Weaken + Try::Tiny + parent + strict + warnings + ) ], + +; + +1; + +# ABSTRACT: Provide information on conflicts for Moose +# Dist::Zilla: -PodWeaver diff --git a/lib/Moose/Cookbook.pod b/lib/Moose/Cookbook.pod new file mode 100644 index 0000000..c967e09 --- /dev/null +++ b/lib/Moose/Cookbook.pod @@ -0,0 +1,289 @@ +# PODNAME: Moose::Cookbook +# ABSTRACT: How to cook a Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook - How to cook a Moose + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Moose cookbook is a series of recipes showing various Moose +features. Most recipes present some code demonstrating some feature, +and then explain the details of the code. + +You should probably read the L<Moose::Manual> first. The manual +explains Moose concepts without being too code-heavy. + +=head1 RECIPES + +=head2 Basic Moose + +These recipes will give you a good overview of Moose's capabilities, 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::Basics::Point_AttributesAndSubclassing> + +A simple Moose-based class. Demonstrates basic Moose attributes and subclassing. + +=item L<Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing> + +A slightly more complex Moose class. Demonstrates using a method modifier in a +subclass. + +=item L<Moose::Cookbook::Basics::BinaryTree_AttributeFeatures> + +Demonstrates several attribute features, including types, weak +references, predicates ("does this object have a foo?"), defaults, +laziness, and triggers. + +=item L<Moose::Cookbook::Basics::Company_Subtypes> + +Introduces the creation and use of custom types, a C<BUILD> method, and the +use of C<override> in a subclass. This recipe also shows how to model a set of +classes that could be used to model companies, people, employees, etc. + +=item L<Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion> + +This recipe covers more subtype creation, including the use of type coercions. + +=item L<Moose::Cookbook::Basics::Immutable> + +Making a class immutable greatly increases the speed of accessors and +object construction. + +=item L<Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild> - 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::Genome_OverloadingSubtypesAndCoercion> + +Demonstrates using operator overloading, coercion, and subtypes to +model how eye color is determined during reproduction. + +=item L<Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD> + +This recipe demonstrates the use of C<BUILDARGS> and C<BUILD> to hook +into object construction. + +=item L<Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent> + +In this recipe, we make a Moose-based subclass of L<DateTime>, a +module which does not use Moose itself. + +=item L<Moose::Cookbook::Basics::Document_AugmentAndInner> + +Demonstrates the use of C<augment> method modifiers, a way of turning +the usual method overriding style "inside-out". + +=back + +=head2 Moose Roles + +These recipes will show you how to use Moose roles. + +=over 4 + +=item L<Moose::Cookbook::Roles::Comparable_CodeReuse> + +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::Roles::Restartable_AdvancedComposition> + +Sometimes you just want to include part of a role in your +class. Sometimes you want the whole role but one of its methods +conflicts with one in your class. With method exclusion and aliasing, +you can work around these problems. + +=item L<Moose::Cookbook::Roles::ApplicationToInstance> + +In this recipe, we apply a role to an existing object instance. + +=back + +=head2 Meta Moose + +These recipes show you how to write your own meta classes, which lets +you extend the object system provided by Moose. + +=over 4 + +=item L<Moose::Cookbook::Meta::WhyMeta> + +If you're wondering what all this "meta" stuff is, and why you should +care about it, read this "recipe". + +=item L<Moose::Cookbook::Meta::Labeled_AttributeTrait> + +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::Meta::Table_MetaclassTrait> + +This recipe takes the class metaclass we saw in the previous recipe +and reimplements it as a metaclass trait. + +=item L<Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass> + +This recipe shows a custom method metaclass that implements making a +method private. + +=item L<Moose::Cookbook::Meta::GlobRef_InstanceMetaclass> + +This recipe shows an example of how you create your own meta-instance +class. The meta-instance determines the internal structure of object +instances and provide access to attribute slots. + +In this particular instance, we use a blessed glob reference as the instance +instead of a blessed hash reference. + +=item Hooking into immutabilization (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. + +=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::ExtensionOverview> + +There are quite a few ways to extend Moose. This recipe provides an +overview of each method, and provides recommendations for when each is +appropriate. + +=item L<Moose::Cookbook::Extending::Debugging_BaseClassRole> + +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::Mooseish_MooseSugar> + +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 + +=head1 Legacy Recipes + +These cover topics that are no longer considered best practice. We've kept +them in case in you encounter these usages in the wild. + +=over 4 + +=item L<Moose::Cookbook::Legacy::Labeled_AttributeMetaclass> + +=item L<Moose::Cookbook::Legacy::Table_ClassMetaclass> + +=item L<Moose::Cookbook::Legacy::Debugging_BaseClassReplacement> + +=back + +=head1 SEE ALSO + +=over 4 + +=item L<http://www.gsph.com/index.php?Lang=En&ID=291> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod b/lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod new file mode 100644 index 0000000..f4874e4 --- /dev/null +++ b/lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod @@ -0,0 +1,384 @@ +# PODNAME: Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing +# ABSTRACT: Demonstrates the use of method modifiers in a subclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing - Demonstrates the use of method modifiers in a subclass + +=head1 VERSION + +version 2.1405 + +=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 were very data-oriented, and did not have much in the way of +behavior (i.e. methods). In this recipe, we expand upon the concepts +from the first recipe to include some real behavior. In particular, we +show how you can use a method modifier to implement new behavior for a +method. + +The classes in the SYNOPSIS show two kinds of bank account. A simple +bank account has one attribute, the balance, and two behaviors, +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 +an 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. (2) + +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 (3). + +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 (4). + +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 (5). + +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/recipes/moose_cookbook_basics_recipe2.t> test file. + +=head1 CONCLUSION + +This recipe expanded on the basic concepts from the first recipe with +a more "real world" use case. + +=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) + +Note that for simple methods like these, which just manipulate some +single piece of data, it is often not necessary to write them at all. +For instance, C<deposit> could be implemented via the C<inc> native +delegation for counters - see +L<Moose::Meta::Attribute::Native::Trait::Counter> for more specifics, +and L<Moose::Meta::Attribute::Native> for a broader overview. + +=item (3) + +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 class is +loaded. + +=item (4) + +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 (5) + +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 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> + +=begin testing + +my $savings_account; + +{ + $savings_account = BankAccount->new( balance => 250 ); + isa_ok( $savings_account, 'BankAccount' ); + + is( $savings_account->balance, 250, '... got the right savings balance' ); + is( + exception { + $savings_account->withdraw(50); + }, + undef, + '... withdrew from savings successfully' + ); + is( $savings_account->balance, 200, + '... got the right savings balance after withdrawal' ); + + $savings_account->deposit(150); + is( $savings_account->balance, 350, + '... got the right savings balance after deposit' ); +} + +{ + my $checking_account = CheckingAccount->new( + balance => 100, + overdraft_account => $savings_account + ); + isa_ok( $checking_account, 'CheckingAccount' ); + isa_ok( $checking_account, 'BankAccount' ); + + is( $checking_account->overdraft_account, $savings_account, + '... got the right overdraft account' ); + + is( $checking_account->balance, 100, + '... got the right checkings balance' ); + + is( + exception { + $checking_account->withdraw(50); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); + is( $savings_account->balance, 350, + '... got the right savings balance after checking withdrawal (no overdraft)' + ); + + is( + exception { + $checking_account->withdraw(200); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 0, + '... got the right checkings balance after withdrawal' ); + is( $savings_account->balance, 200, + '... got the right savings balance after overdraft withdrawal' ); +} + +{ + my $checking_account = CheckingAccount->new( + balance => 100 + + # no overdraft account + ); + isa_ok( $checking_account, 'CheckingAccount' ); + isa_ok( $checking_account, 'BankAccount' ); + + is( $checking_account->overdraft_account, undef, + '... no overdraft account' ); + + is( $checking_account->balance, 100, + '... got the right checkings balance' ); + + is( + exception { + $checking_account->withdraw(50); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); + + isnt( + exception { + $checking_account->withdraw(200); + }, + undef, + '... withdrawal failed due to attempted overdraft' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal failure' ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod b/lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod new file mode 100644 index 0000000..09cdf3f --- /dev/null +++ b/lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod @@ -0,0 +1,397 @@ +# PODNAME: Moose::Cookbook::Basics::BinaryTree_AttributeFeatures +# ABSTRACT: Demonstrates various attribute features including lazy, predicates, weak refs, and more + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::BinaryTree_AttributeFeatures - Demonstrates various attribute features including lazy, predicates, weak refs, and more + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package BinaryTree; + use Moose; + + has 'node' => ( is => 'rw', isa => 'Any' ); + + has 'parent' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_parent', + weak_ref => 1, + ); + + has 'left' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_left', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + + has 'right' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_right', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + + sub _set_parent_for_child { + my ( $self, $child ) = @_; + + confess "You cannot insert a tree which already has a parent" + if $child->has_parent; + + $child->parent($self); + } + +=head1 DESCRIPTION + +This recipe shows how various advanced attribute features can be used +to create complex and powerful behaviors. In particular, we introduce +a number of new attribute options, including C<predicate>, C<lazy>, +and C<trigger>. + +The example class is a classic binary tree. Each node in the tree is +itself an instance of C<BinaryTree>. It has a C<node>, which holds +some arbitrary value. It has C<right> and C<left> attributes, which +refer to its child trees, and a C<parent>. + +Let's take a look at the C<node> attribute: + + has 'node' => ( is => 'rw', isa => 'Any' ); + +Moose generates a read-write accessor for this attribute. The type +constraint is C<Any>, which literally means it can contain anything. + +We could have left out the C<isa> option, but in this case, we are +including it for the benefit of other programmers, not the computer. + +Next, let's move on to the C<parent> attribute: + + has 'parent' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_parent', + weak_ref => 1, + ); + +Again, we have a read-write accessor. This time, the C<isa> option +says that this attribute must always be an instance of +C<BinaryTree>. In the second recipe, we saw that every time we create +a Moose-based class, we also get a corresponding class type +constraint. + +The C<predicate> option is new. It creates a method which can be used +to check whether or not a given attribute has been initialized. In +this case, the method is named C<has_parent>. + +This brings us to our last attribute option, C<weak_ref>. Since +C<parent> is a circular reference (the tree in C<parent> should +already have a reference to this one, in its C<left> or C<right> +attribute), we want to make sure that we weaken the reference to avoid +memory leaks. If C<weak_ref> is true, it alters the accessor function +so that the reference is weakened when it is set. + +Finally, we have the C<left> and C<right> attributes. They are +essentially identical except for their names, so we'll just look at +C<left>: + + has 'left' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_left', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + +There are three new options here, C<lazy>, C<default>, and +C<trigger>. The C<lazy> and C<default> options are linked. In fact, +you cannot have a C<lazy> attribute unless it has a C<default> +(or a C<builder>, but we'll cover that later). If you try to make an +attribute lazy without a default, class creation will fail with an +exception. (2) + +In the second recipe the B<BankAccount>'s C<balance> attribute had a +default value of C<0>. Given a non-reference, Perl copies the +I<value>. However, given a reference, it does not do a deep clone, +instead simply copying the reference. If you just specified a simple +reference for a default, Perl would create it once and it would be +shared by all objects with that attribute. + +As a workaround, we use an anonymous subroutine to generate a new +reference every time the default is called. + + has 'foo' => ( is => 'rw', default => sub { [] } ); + +In fact, using a non-subroutine reference as a default is illegal in Moose. + + # will fail + has 'foo' => ( is => 'rw', default => [] ); + +This will blow up, so don't do it. + +You'll notice that we use C<$_[0]> in our default sub. When the +default subroutine is executed, it is called as a method on the +object. + +In our case, we're making a new C<BinaryTree> object in our default, +with the current tree as the parent. + +Normally, when an object is instantiated, any defaults are evaluated +immediately. With our C<BinaryTree> class, this would be a big +problem! We'd create the first object, which would immediately try to +populate its C<left> and C<right> attributes, which would create a new +C<BinaryTree>, which would populate I<its> C<left> and C<right> +slots. Kaboom! + +By making our C<left> and C<right> attributes C<lazy>, we avoid this +problem. If the attribute has a value when it is read, the default is +never executed at all. + +We still have one last bit of behavior to add. The autogenerated +C<right> and C<left> accessors are not quite correct. When one of +these is set, we want to make sure that we update the parent of the +C<left> or C<right> attribute's tree. + +We could write our own accessors, but then why use Moose at all? +Instead, we use a C<trigger>. A C<trigger> accepts a subroutine +reference, which will be called as a method whenever the attribute is +set. This can happen both during object construction or later by +passing a new object to the attribute's accessor method. However, it +is not called when a value is provided by a C<default> or C<builder>. + + sub _set_parent_for_child { + my ( $self, $child ) = @_; + + confess "You cannot insert a tree which already has a parent" + if $child->has_parent; + + $child->parent($self); + } + +This trigger does two things. First, it ensures that the new child +node does not already have a parent. This is done for the sake of +simplifying the example. If we wanted to be more clever, we would +remove the child from its old parent tree and add it to the new one. + +If the child has no parent, we will add it to the current tree, and we +ensure that is has the correct value for its C<parent> attribute. + +As with all the other recipes, B<BinaryTree> can be used just like any +other Perl 5 class. A more detailed example of its usage can be found +in F<t/recipes/moose_cookbook_basics_recipe3.t>. + +=head1 CONCLUSION + +This recipe introduced several of Moose's advanced features. We hope +that this inspires you to think of other ways these features can be +used to simplify your code. + +=head1 FOOTNOTES + +=over 4 + +=item (1) + +Weak references are tricky things, and should be used sparingly and +appropriately (such as in the case of circular refs). If you are not +careful, attribute values could disappear "mysteriously" because +Perl's reference counting garbage collector has gone and removed the +item you are weak-referencing. + +In short, don't use them unless you know what you are doing :) + +=item (2) + +You I<can> use the C<default> option without the C<lazy> option if you +like, as we showed in the second recipe. + +Also, you can use C<builder> instead of C<default>. See +L<Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild> for details. + +=back + +=begin testing + +use Scalar::Util 'isweak'; + +my $root = BinaryTree->new(node => 'root'); +isa_ok($root, 'BinaryTree'); + +is($root->node, 'root', '... got the right node value'); + +ok(!$root->has_left, '... no left node yet'); +ok(!$root->has_right, '... no right node yet'); + +ok(!$root->has_parent, '... no parent for root node'); + +# make a left node + +my $left = $root->left; +isa_ok($left, 'BinaryTree'); + +is($root->left, $left, '... got the same node (and it is $left)'); +ok($root->has_left, '... we have a left node now'); + +ok($left->has_parent, '... lefts has a parent'); +is($left->parent, $root, '... lefts parent is the root'); + +ok(isweak($left->{parent}), '... parent is a weakened ref'); + +ok(!$left->has_left, '... $left no left node yet'); +ok(!$left->has_right, '... $left no right node yet'); + +is($left->node, undef, '... left has got no node value'); + +is( + exception { + $left->node('left'); + }, + undef, + '... assign to lefts node' +); + +is($left->node, 'left', '... left now has a node value'); + +# make a right node + +ok(!$root->has_right, '... still no right node yet'); + +is($root->right->node, undef, '... right has got no node value'); + +ok($root->has_right, '... now we have a right node'); + +my $right = $root->right; +isa_ok($right, 'BinaryTree'); + +is( + exception { + $right->node('right'); + }, + undef, + '... assign to rights node' +); + +is($right->node, 'right', '... left now has a node value'); + +is($root->right, $right, '... got the same node (and it is $right)'); +ok($root->has_right, '... we have a right node now'); + +ok($right->has_parent, '... rights has a parent'); +is($right->parent, $root, '... rights parent is the root'); + +ok(isweak($right->{parent}), '... parent is a weakened ref'); + +# make a left node of the left node + +my $left_left = $left->left; +isa_ok($left_left, 'BinaryTree'); + +ok($left_left->has_parent, '... left does have a parent'); + +is($left_left->parent, $left, '... got a parent node (and it is $left)'); +ok($left->has_left, '... we have a left node now'); +is($left->left, $left_left, '... got a left node (and it is $left_left)'); + +ok(isweak($left_left->{parent}), '... parent is a weakened ref'); + +# make a right node of the left node + +my $left_right = BinaryTree->new; +isa_ok($left_right, 'BinaryTree'); + +is( + exception { + $left->right($left_right); + }, + undef, + '... assign to rights node' +); + +ok($left_right->has_parent, '... left does have a parent'); + +is($left_right->parent, $left, '... got a parent node (and it is $left)'); +ok($left->has_right, '... we have a left node now'); +is($left->right, $left_right, '... got a left node (and it is $left_left)'); + +ok(isweak($left_right->{parent}), '... parent is a weakened ref'); + +# and check the error + +isnt( + exception { + $left_right->right($left_left); + }, + undef, + '... cannot assign a node which already has a parent' +); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod b/lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod new file mode 100644 index 0000000..025968a --- /dev/null +++ b/lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod @@ -0,0 +1,176 @@ +# PODNAME: Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild +# ABSTRACT: Builder methods and lazy_build + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild - Builder methods and lazy_build + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package BinaryTree; + use Moose; + + has 'node' => (is => 'rw', isa => 'Any'); + + has 'parent' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_parent', + weak_ref => 1, + ); + + has 'left' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_left', + lazy => 1, + builder => '_build_child_tree', + ); + + has 'right' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_right', + lazy => 1, + builder => '_build_child_tree', + ); + + before 'right', 'left' => sub { + my ($self, $tree) = @_; + $tree->parent($self) if defined $tree; + }; + + sub _build_child_tree { + my $self = shift; + + return BinaryTree->new( parent => $self ); + } + +=head1 DESCRIPTION + +If you've already read +L<Moose::Cookbook::Basics::BinaryTree_AttributeFeatures>, then this example +should look very familiar. In fact, all we've done here is replace the +attribute's C<default> parameter with a C<builder>. + +In this particular case, the C<default> and C<builder> options act in +exactly the same way. When the C<left> or C<right> attribute is read, +Moose calls the builder method to initialize the attribute. + +Note that Moose calls the builder method I<on the object which has the +attribute>. Here's an example: + + my $tree = BinaryTree->new(); + + my $left = $tree->left(); + +When C<< $tree->left() >> is called, Moose calls C<< +$tree->_build_child_tree() >> in order to populate the C<left> +attribute. If we had passed C<left> to the original constructor, the +builder would not be called. + +There are some differences between C<default> and C<builder>. Notably, +a builder is subclassable, and can be composed from a role. See +L<Moose::Manual::Attributes> for more details. + +=head2 The lazy_build shortcut + +The C<lazy_build> attribute option can be used as sugar to specify +a whole set of attribute options at once: + + has 'animal' => ( + is => 'ro', + isa => 'Animal', + lazy_build => 1, + ); + +This is a shorthand for: + + has 'animal' => ( + is => 'ro', + isa => 'Animal', + required => 1, + lazy => 1, + builder => '_build_animal', + predicate => 'has_animal', + clearer => 'clear_animal', + ); + +If your attribute starts with an underscore, Moose is smart and will +do the right thing with the C<predicate> and C<clearer>, making them +both start with an underscore. The C<builder> method I<always> starts +with an underscore. + +You can read more about C<lazy_build> in L<Moose::Meta::Attribute> + +=head1 CONCLUSION + +The C<builder> option is a more OO-friendly version of the C<default> +functionality. It also separates the default-generating code into a +well-defined method. Sprinkling your attribute definitions with +anonymous subroutines can be quite ugly and hard to follow. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/Company_Subtypes.pod b/lib/Moose/Cookbook/Basics/Company_Subtypes.pod new file mode 100644 index 0000000..1b062f5 --- /dev/null +++ b/lib/Moose/Cookbook/Basics/Company_Subtypes.pod @@ -0,0 +1,602 @@ +# PODNAME: Moose::Cookbook::Basics::Company_Subtypes +# ABSTRACT: Demonstrates the use of subtypes and how to model classes related to companies, people, employees, etc. + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::Company_Subtypes - Demonstrates the use of subtypes and how to model classes related to companies, people, employees, etc. + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Address; + use Moose; + use Moose::Util::TypeConstraints; + + use Locale::US; + use Regexp::Common 'zip'; + + my $STATES = Locale::US->new; + subtype 'USState' + => as Str + => where { + ( exists $STATES->{code2state}{ uc($_) } + || exists $STATES->{state2code}{ uc($_) } ); + }; + + subtype 'USZipCode' + => as Value + => where { + /^$RE{zip}{US}{-extended => 'allow'}$/; + }; + + has 'street' => ( is => 'rw', isa => 'Str' ); + has 'city' => ( is => 'rw', isa => 'Str' ); + has 'state' => ( is => 'rw', isa => 'USState' ); + has 'zip_code' => ( is => 'rw', isa => 'USZipCode' ); + + package Company; + use Moose; + use Moose::Util::TypeConstraints; + + has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'address' => ( is => 'rw', isa => 'Address' ); + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]', + default => sub { [] }, + ); + + sub BUILD { + my ( $self, $params ) = @_; + foreach my $employee ( @{ $self->employees } ) { + $employee->employer($self); + } + } + + after 'employees' => sub { + my ( $self, $employees ) = @_; + return unless $employees; + foreach my $employee ( @$employees ) { + $employee->employer($self); + } + }; + + package Person; + use Moose; + + has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'middle_initial' => ( + is => 'rw', isa => 'Str', + predicate => 'has_middle_initial' + ); + has 'address' => ( is => 'rw', isa => 'Address' ); + + sub full_name { + my $self = shift; + return $self->first_name + . ( + $self->has_middle_initial + ? ' ' . $self->middle_initial . '. ' + : ' ' + ) . $self->last_name; + } + + package Employee; + use Moose; + + extends 'Person'; + + has 'title' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 ); + + override 'full_name' => sub { + my $self = shift; + super() . ', ' . $self->title; + }; + +=head1 DESCRIPTION + +This recipe introduces the C<subtype> sugar function from +L<Moose::Util::TypeConstraints>. The C<subtype> function lets you +declaratively create type constraints without building an entire +class. + +In the recipe we also make use of L<Locale::US> and L<Regexp::Common> +to build constraints, showing how constraints can make use of existing +CPAN tools for data validation. + +Finally, we introduce the C<required> attribute option. + +In the C<Address> class we define two subtypes. The first uses the +L<Locale::US> module to check the validity of a state. It accepts +either a state abbreviation of full name. + +A state will be passed in as a string, so we make our C<USState> type +a subtype of Moose's builtin C<Str> type. This is done using the C<as> +sugar. The actual constraint is defined using C<where>. This function +accepts a single subroutine reference. That subroutine will be called +with the value to be checked in C<$_> (1). It is expected to return a +true or false value indicating whether the value is valid for the +type. + +We can now use the C<USState> type just like Moose's builtin types: + + has 'state' => ( is => 'rw', isa => 'USState' ); + +When the C<state> attribute is set, the value is checked against the +C<USState> constraint. If the value is not valid, an exception will be +thrown. + +The next C<subtype>, C<USZipCode>, uses +L<Regexp::Common>. L<Regexp::Common> includes a regex for validating +US zip codes. We use this constraint for the C<zip_code> attribute. + + subtype 'USZipCode' + => as Value + => where { + /^$RE{zip}{US}{-extended => 'allow'}$/; + }; + +Using a subtype instead of requiring a class for each type greatly +simplifies the code. We don't really need a class for these types, as +they're just strings, but we do want to ensure that they're valid. + +The type constraints we created are reusable. Type constraints are +stored by name in a global registry, which means that we can refer to +them in other classes. Because the registry is global, we do recommend +that you use some sort of namespacing in real applications, +like C<MyApp::Type::USState> (just as you would do with class names). + +These two subtypes allow us to define a simple C<Address> class. + +Then we define our C<Company> class, which has an address. As we saw +in earlier recipes, Moose automatically creates a type constraint for +each our classes, so we can use that for the C<Company> class's +C<address> attribute: + + has 'address' => ( is => 'rw', isa => 'Address' ); + +A company also needs a name: + + has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); + +This introduces a new attribute option, C<required>. If an attribute +is required, then it must be passed to the class's constructor, or an +exception will be thrown. It's important to understand that a +C<required> attribute can still be false or C<undef>, if its type +constraint allows that. + +The next attribute, C<employees>, uses a I<parameterized> type +constraint: + + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]' + default => sub { [] }, + ); + +This constraint says that C<employees> must be an array reference +where each element of the array is an C<Employee> object. It's worth +noting that an I<empty> array reference also satisfies this +constraint, such as the value given as the default here. + +Parameterizable type constraints (or "container types"), such as +C<ArrayRef[`a]>, can be made more specific with a type parameter. In +fact, we can arbitrarily nest these types, producing something like +C<HashRef[ArrayRef[Int]]>. However, you can also just use the type by +itself, so C<ArrayRef> is legal. (2) + +If you jump down to the definition of the C<Employee> class, you will +see that it has an C<employer> attribute. + +When we set the C<employees> for a C<Company> we want to make sure +that each of these employee objects refers back to the right +C<Company> in its C<employer> attribute. + +To do that, we need to hook into object construction. Moose lets us do +this by writing a C<BUILD> method in our class. When your class +defines a C<BUILD> method, it will be called by the constructor +immediately after object construction, but before the object is returned +to the caller. Note that all C<BUILD> methods in your class hierarchy +will be called automatically; there is no need to (and you should not) +call the superclass C<BUILD> method. + +The C<Company> class uses the C<BUILD> method to ensure that each +employee of a company has the proper C<Company> object in its +C<employer> attribute: + + sub BUILD { + my ( $self, $params ) = @_; + foreach my $employee ( @{ $self->employees } ) { + $employee->employer($self); + } + } + +The C<BUILD> method is executed after type constraints are checked, so it is +safe to assume that if C<< $self->employees >> has a value, it will be an +array reference, and that the elements of that array reference will be +C<Employee> objects. + +We also want to make sure that whenever the C<employees> attribute for +a C<Company> is changed, we also update the C<employer> for each +employee. + +To do this we can use an C<after> modifier: + + after 'employees' => sub { + my ( $self, $employees ) = @_; + return unless $employees; + foreach my $employee ( @$employees ) { + $employee->employer($self); + } + }; + +Again, as with the C<BUILD> method, we know that the type constraint check has +already happened, so we know that if C<$employees> is defined it will contain +an array reference of C<Employee> objects. + +Note that C<employees> is a read/write accessor, so we must return early if +it's called as a reader. + +The B<Person> class does not really demonstrate anything new. It has several +C<required> attributes. It also has a C<predicate> method, which we +first used in L<Moose::Cookbook::Basics::BinaryTree_AttributeFeatures>. + +The only new feature in the C<Employee> class is the C<override> +method modifier: + + override 'full_name' => sub { + my $self = shift; + super() . ', ' . $self->title; + }; + +This is just a sugary alternative to Perl's built in C<SUPER::> +feature. However, there is one difference. You cannot pass any +arguments to C<super>. Instead, Moose simply passes the same +parameters that were passed to the method. + +A more detailed example of usage can be found in +F<t/recipes/moose_cookbook_basics_recipe4.t>. + +=for testing-SETUP use Test::Requires { + 'Locale::US' => '0', + 'Regexp::Common' => '0', +}; + +=head1 CONCLUSION + +This recipe was intentionally longer and more complex. It illustrates +how Moose classes can be used together with type constraints, as well +as the density of information that you can get out of a small amount +of typing when using Moose. + +This recipe also introduced the C<subtype> function, the C<required> +attribute, and the C<override> method modifier. + +We will revisit type constraints in future recipes, and cover type +coercion as well. + +=head1 FOOTNOTES + +=over 4 + +=item (1) + +The value being checked is also passed as the first argument to +the C<where> block, so it can be accessed as C<$_[0]>. + +=item (2) + +Note that C<ArrayRef[]> will not work. Moose will not parse this as a +container type, and instead you will have a new type named +"ArrayRef[]", which doesn't make any sense. + +=back + +=begin testing + +{ + package Company; + + sub get_employee_count { scalar @{(shift)->employees} } +} + +use Scalar::Util 'isweak'; + +my $ii; +is( + exception { + $ii = Company->new( + { + name => 'Infinity Interactive', + address => Address->new( + street => '565 Plandome Rd., Suite 307', + city => 'Manhasset', + state => 'NY', + zip_code => '11030' + ), + employees => [ + Employee->new( + first_name => 'Jeremy', + last_name => 'Shao', + title => 'President / Senior Consultant', + address => Address->new( + city => 'Manhasset', state => 'NY' + ) + ), + Employee->new( + first_name => 'Tommy', + last_name => 'Lee', + title => 'Vice President / Senior Developer', + address => + Address->new( city => 'New York', state => 'NY' ) + ), + Employee->new( + first_name => 'Stevan', + middle_initial => 'C', + last_name => 'Little', + title => 'Senior Developer', + address => + Address->new( city => 'Madison', state => 'CT' ) + ), + ] + } + ); + }, + undef, + '... created the entire company successfully' +); + +isa_ok( $ii, 'Company' ); + +is( $ii->name, 'Infinity Interactive', + '... got the right name for the company' ); + +isa_ok( $ii->address, 'Address' ); +is( $ii->address->street, '565 Plandome Rd., Suite 307', + '... got the right street address' ); +is( $ii->address->city, 'Manhasset', '... got the right city' ); +is( $ii->address->state, 'NY', '... got the right state' ); +is( $ii->address->zip_code, 11030, '... got the zip code' ); + +is( $ii->get_employee_count, 3, '... got the right employee count' ); + +# employee #1 + +isa_ok( $ii->employees->[0], 'Employee' ); +isa_ok( $ii->employees->[0], 'Person' ); + +is( $ii->employees->[0]->first_name, 'Jeremy', + '... got the right first name' ); +is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' ); +ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' ); +is( $ii->employees->[0]->middle_initial, undef, + '... got the right middle initial value' ); +is( $ii->employees->[0]->full_name, + 'Jeremy Shao, President / Senior Consultant', + '... got the right full name' ); +is( $ii->employees->[0]->title, 'President / Senior Consultant', + '... got the right title' ); +is( $ii->employees->[0]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[0]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[0]->address, 'Address' ); +is( $ii->employees->[0]->address->city, 'Manhasset', + '... got the right city' ); +is( $ii->employees->[0]->address->state, 'NY', '... got the right state' ); + +# employee #2 + +isa_ok( $ii->employees->[1], 'Employee' ); +isa_ok( $ii->employees->[1], 'Person' ); + +is( $ii->employees->[1]->first_name, 'Tommy', + '... got the right first name' ); +is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' ); +ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' ); +is( $ii->employees->[1]->middle_initial, undef, + '... got the right middle initial value' ); +is( $ii->employees->[1]->full_name, + 'Tommy Lee, Vice President / Senior Developer', + '... got the right full name' ); +is( $ii->employees->[1]->title, 'Vice President / Senior Developer', + '... got the right title' ); +is( $ii->employees->[1]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[1]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[1]->address, 'Address' ); +is( $ii->employees->[1]->address->city, 'New York', + '... got the right city' ); +is( $ii->employees->[1]->address->state, 'NY', '... got the right state' ); + +# employee #3 + +isa_ok( $ii->employees->[2], 'Employee' ); +isa_ok( $ii->employees->[2], 'Person' ); + +is( $ii->employees->[2]->first_name, 'Stevan', + '... got the right first name' ); +is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' ); +ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' ); +is( $ii->employees->[2]->middle_initial, 'C', + '... got the right middle initial value' ); +is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', + '... got the right full name' ); +is( $ii->employees->[2]->title, 'Senior Developer', + '... got the right title' ); +is( $ii->employees->[2]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[2]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[2]->address, 'Address' ); +is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' ); +is( $ii->employees->[2]->address->state, 'CT', '... got the right state' ); + +# create new company + +my $new_company + = Company->new( name => 'Infinity Interactive International' ); +isa_ok( $new_company, 'Company' ); + +my $ii_employees = $ii->employees; +foreach my $employee (@$ii_employees) { + is( $employee->employer, $ii, '... has the ii company' ); +} + +$new_company->employees($ii_employees); + +foreach my $employee ( @{ $new_company->employees } ) { + is( $employee->employer, $new_company, + '... has the different company now' ); +} + +## check some error conditions for the subtypes + +isnt( + exception { + Address->new( street => {} ),; + }, + undef, + '... we die correctly with bad args' +); + +isnt( + exception { + Address->new( city => {} ),; + }, + undef, + '... we die correctly with bad args' +); + +isnt( + exception { + Address->new( state => 'British Columbia' ),; + }, + undef, + '... we die correctly with bad args' +); + +is( + exception { + Address->new( state => 'Connecticut' ),; + }, + undef, + '... we live correctly with good args' +); + +isnt( + exception { + Address->new( zip_code => 'AF5J6$' ),; + }, + undef, + '... we die correctly with bad args' +); + +is( + exception { + Address->new( zip_code => '06443' ),; + }, + undef, + '... we live correctly with good args' +); + +isnt( + exception { + Company->new(),; + }, + undef, + '... we die correctly without good args' +); + +is( + exception { + Company->new( name => 'Foo' ),; + }, + undef, + '... we live correctly without good args' +); + +isnt( + exception { + Company->new( name => 'Foo', employees => [ Person->new ] ),; + }, + undef, + '... we die correctly with good args' +); + +is( + exception { + Company->new( name => 'Foo', employees => [] ),; + }, + undef, + '... we live correctly with good args' +); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod b/lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod new file mode 100644 index 0000000..89ef739 --- /dev/null +++ b/lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod @@ -0,0 +1,134 @@ +# PODNAME: Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent +# ABSTRACT: Extending a non-Moose parent class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent - Extending a non-Moose parent class + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package My::DateTime; + + use Moose; + use MooseX::NonMoose; + use DateTime::Calendar::Mayan; + extends qw( DateTime ); + + has 'mayan_date' => ( + is => 'ro', + isa => 'DateTime::Calendar::Mayan', + init_arg => undef, + lazy => 1, + builder => '_build_mayan_date', + clearer => '_clear_mayan_date', + predicate => 'has_mayan_date', + ); + + after 'set' => sub { + $_[0]->_clear_mayan_date; + }; + + sub _build_mayan_date { + DateTime::Calendar::Mayan->from_object( object => $_[0] ); + } + +=head1 DESCRIPTION + +This recipe demonstrates how to use Moose to subclass a parent which +is not Moose based. This recipe only works if the parent class uses a +blessed hash reference for object instances. If your parent is doing +something funkier, you should check out L<MooseX::NonMoose::InsideOut> and L<MooseX::InsideOut>. + +The meat of this recipe is contained in L<MooseX::NonMoose>, which does all +the grunt work for you. + +=begin testing-SETUP + +# because MooseX::NonMoose has a version requirement +BEGIN { $Moose::Role::VERSION = 9999 unless $Moose::Role::VERSION } + +use Test::Requires { + 'DateTime' => '0', + 'DateTime::Calendar::Mayan' => '0', + 'MooseX::NonMoose' => '0.25', +}; + +=end testing-SETUP + +=begin testing + +my $dt = My::DateTime->new( year => 1970, month => 2, day => 24 ); + +can_ok( $dt, 'mayan_date' ); +isa_ok( $dt->mayan_date, 'DateTime::Calendar::Mayan' ); +is( $dt->mayan_date->date, '12.17.16.9.19', 'got expected mayan date' ); + +$dt->set( year => 2009 ); +ok( ! $dt->has_mayan_date, 'mayan_date is cleared after call to ->set' ); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod b/lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod new file mode 100644 index 0000000..1551745 --- /dev/null +++ b/lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod @@ -0,0 +1,197 @@ +# PODNAME: Moose::Cookbook::Basics::Document_AugmentAndInner +# ABSTRACT: The augment modifier, which turns normal method overriding "inside-out" + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::Document_AugmentAndInner - The augment modifier, which turns normal method overriding "inside-out" + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Document::Page; + use Moose; + + has 'body' => ( is => 'rw', isa => 'Str', default => sub {''} ); + + sub create { + my $self = shift; + $self->open_page; + inner(); + $self->close_page; + } + + sub append_body { + my ( $self, $appendage ) = @_; + $self->body( $self->body . $appendage ); + } + + sub open_page { (shift)->append_body('<page>') } + sub close_page { (shift)->append_body('</page>') } + + package Document::PageWithHeadersAndFooters; + use Moose; + + extends 'Document::Page'; + + augment 'create' => sub { + my $self = shift; + $self->create_header; + inner(); + $self->create_footer; + }; + + sub create_header { (shift)->append_body('<header/>') } + sub create_footer { (shift)->append_body('<footer/>') } + + package TPSReport; + use Moose; + + extends 'Document::PageWithHeadersAndFooters'; + + augment 'create' => sub { + my $self = shift; + $self->create_tps_report; + inner(); + }; + + sub create_tps_report { + (shift)->append_body('<report type="tps"/>'); + } + + # <page><header/><report type="tps"/><footer/></page> + my $report_xml = TPSReport->new->create; + +=head1 DESCRIPTION + +This recipe shows how the C<augment> method modifier works. This +modifier reverses the normal subclass to parent method resolution +order. With an C<augment> modifier the I<least> specific method is +called first. Each successive call to C<inner> descends the +inheritance tree, ending at the most specific subclass. + +The C<augment> modifier lets you design a parent class that can be +extended in a specific way. The parent provides generic wrapper +functionality, and the subclasses fill in the details. + +In the example above, we've created a set of document classes, with +the most specific being the C<TPSReport> class. + +We start with the least specific class, C<Document::Page>. Its create +method contains a call to C<inner()>: + + sub create { + my $self = shift; + $self->open_page; + inner(); + $self->close_page; + } + +The C<inner> function is exported by C<Moose>, and is like C<super> +for augmented methods. When C<inner> is called, Moose finds the next +method in the chain, which is the C<augment> modifier in +C<Document::PageWithHeadersAndFooters>. You'll note that we can call +C<inner> in our modifier: + + augment 'create' => sub { + my $self = shift; + $self->create_header; + inner(); + $self->create_footer; + }; + +This finds the next most specific modifier, in the C<TPSReport> class. + +Finally, in the C<TPSReport> class, the chain comes to an end: + + augment 'create' => sub { + my $self = shift; + $self->create_tps_report; + inner(); + }; + +We do call the C<inner> function one more time, but since there is no +more specific subclass, this is a no-op. Making this call means we can +easily subclass C<TPSReport> in the future. + +=head1 CONCLUSION + +The C<augment> modifier is a powerful tool for creating a set of +nested wrappers. It's not something you will need often, but when you +do, it is very handy. + +=begin testing + +my $tps_report = TPSReport->new; +isa_ok( $tps_report, 'TPSReport' ); + +is( + $tps_report->create, + q{<page><header/><report type="tps"/><footer/></page>}, + '... got the right TPS report' +); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod b/lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod new file mode 100644 index 0000000..2311ac3 --- /dev/null +++ b/lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod @@ -0,0 +1,325 @@ +# PODNAME: Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion +# ABSTRACT: Operator overloading, subtypes, and coercion + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion - Operator overloading, subtypes, and coercion + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Human; + + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Sex' + => as 'Str' + => where { $_ =~ m{^[mf]$}s }; + + has 'sex' => ( is => 'ro', isa => 'Sex', required => 1 ); + + has 'mother' => ( is => 'ro', isa => 'Human' ); + has 'father' => ( is => 'ro', isa => 'Human' ); + + use overload '+' => \&_overload_add, fallback => 1; + + sub _overload_add { + my ( $one, $two ) = @_; + + die('Only male and female humans may create children') + if ( $one->sex() eq $two->sex() ); + + my ( $mother, $father ) + = ( $one->sex eq 'f' ? ( $one, $two ) : ( $two, $one ) ); + + my $sex = 'f'; + $sex = 'm' if ( rand() >= 0.5 ); + + return Human->new( + sex => $sex, + mother => $mother, + father => $father, + ); + } + +=head1 DESCRIPTION + +This Moose cookbook recipe shows how operator overloading, coercion, +and subtypes can be used to mimic the human reproductive system +(well, the selection of genes at least). + +=head1 INTRODUCTION + +Our C<Human> class uses operator overloading to allow us to "add" two +humans together and produce a child. Our implementation does require +that the two objects be of opposite sex. Remember, we're talking +about biological reproduction, not marriage. + +While this example works as-is, we can take it a lot further by adding +genes into the mix. We'll add the two genes that control eye color, +and use overloading to combine the genes from the parent to model the +biology. + +=head2 What is Operator Overloading? + +Overloading is I<not> a Moose-specific feature. It's a general OO +concept that is implemented in Perl with the C<overload> +pragma. Overloading lets objects do something sane when used with +Perl's built in operators, like addition (C<+>) or when used as a +string. + +In this example we overload addition so we can write code like +C<$child = $mother + $father>. + +=head1 GENES + +There are many genes which affect eye color, but there are two which +are most important, I<gey> and I<bey2>. We will start by making a +class for each gene. + +=head2 Human::Gene::bey2 + + package Human::Gene::bey2; + + use Moose; + use Moose::Util::TypeConstraints; + + type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} }; + + has 'color' => ( is => 'ro', isa => 'bey2_color' ); + +This class is trivial. We have a type constraint for the allowed +colors, and a C<color> attribute. + +=head2 Human::Gene::gey + + package Human::Gene::gey; + + use Moose; + use Moose::Util::TypeConstraints; + + type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} }; + + has 'color' => ( is => 'ro', isa => 'gey_color' ); + +This is nearly identical to the C<Humane::Gene::bey2> class, except +that the I<gey> gene allows for different colors. + +=head1 EYE COLOR + +We could just give four attributes (two of each gene) to the +C<Human> class, but this is a bit messy. Instead, we'll abstract the +genes into a container class, C<Human::EyeColor>. Then a C<Human> can +have a single C<eye_color> attribute. + + package Human::EyeColor; + + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Human::Gene::bey2' + => from 'Str' + => via { Human::Gene::bey2->new( color => $_ ) }; + + coerce 'Human::Gene::gey' + => from 'Str' + => via { Human::Gene::gey->new( color => $_ ) }; + + has [qw( bey2_1 bey2_2 )] => + ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 ); + + has [qw( gey_1 gey_2 )] => + ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 ); + +The eye color class has two of each type of gene. We've also created a +coercion for each class that coerces a string into a new object. Note +that a coercion will fail if it attempts to coerce a string like +"indigo", because that is not a valid color for either type of gene. + +As an aside, you can see that we can define several identical +attributes at once by supplying an array reference of names as the first +argument to C<has>. + +We also need a method to calculate the actual eye color that results +from a set of genes. The I<bey2> brown gene is dominant over both blue +and green. The I<gey> green gene is dominant over blue. + + 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'; + } + +We'd like to be able to treat a C<Human::EyeColor> object as a string, +so we define a string overloading for the class: + + use overload '""' => \&color, fallback => 1; + +Finally, we need to define overloading for addition. That way we can +add together two C<Human::EyeColor> objects and get a new one with a +new (genetically correct) eye color. + + 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) ); + } + +When two eye color objects are added together, the C<_overload_add()> +method will be passed two C<Human::EyeColor> objects. These are the +left and right side operands for the C<+> operator. This method +returns a new C<Human::EyeColor> object. + +=head1 ADDING EYE COLOR TO C<Human>s + +Our original C<Human> class requires just a few changes to incorporate +our new C<Human::EyeColor> class. + + use List::MoreUtils qw( zip ); + + coerce 'Human::EyeColor' + => from 'ArrayRef' + => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); + return Human::EyeColor->new( zip( @genes, @{$_} ) ); }; + + has 'eye_color' => ( + is => 'ro', + isa => 'Human::EyeColor', + coerce => 1, + required => 1, + ); + +We also need to modify C<_overload_add()> in the C<Human> class to +account for eye color: + + return Human->new( + sex => $sex, + eye_color => ( $one->eye_color() + $two->eye_color() ), + mother => $mother, + father => $father, + ); + +=head1 CONCLUSION + +The three techniques we used, overloading, subtypes, and coercion, +combine to provide a powerful interface. + +If you'd like to learn more about overloading, please read the +documentation for the L<overload> pragma. + +To see all the code we created together, take a look at +F<t/recipes/basics_recipe9.t>. + +=head1 NEXT STEPS + +Had this been a real project we'd probably want: + +=over 4 + +=item Better Randomization with Crypt::Random + +=item Characteristic Base Class + +=item Mutating Genes + +=item More Characteristics + +=item Artificial Life + +=back + +=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/> + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod b/lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod new file mode 100644 index 0000000..8f0783b --- /dev/null +++ b/lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod @@ -0,0 +1,345 @@ +# PODNAME: Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion +# ABSTRACT: Demonstrates subtypes and coercion use HTTP-related classes (Request, Protocol, etc.) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion - Demonstrates subtypes and coercion use HTTP-related classes (Request, Protocol, etc.) + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Request; + use Moose; + use Moose::Util::TypeConstraints; + + use HTTP::Headers (); + use Params::Coerce (); + use URI (); + + subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers'); + + coerce 'My::Types::HTTP::Headers' + => from 'ArrayRef' + => via { HTTP::Headers->new( @{$_} ) } + => from 'HashRef' + => via { HTTP::Headers->new( %{$_} ) }; + + subtype 'My::Types::URI' => as class_type('URI'); + + coerce 'My::Types::URI' + => from 'Object' + => via { $_->isa('URI') + ? $_ + : Params::Coerce::coerce( 'URI', $_ ); } + => from 'Str' + => via { URI->new( $_, 'http' ) }; + + subtype 'Protocol' + => as 'Str' + => where { /^HTTP\/[0-9]\.[0-9]$/ }; + + has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'uri' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'method' => ( is => 'rw', isa => 'Str' ); + has 'protocol' => ( is => 'rw', isa => 'Protocol' ); + has 'headers' => ( + is => 'rw', + isa => 'My::Types::HTTP::Headers', + coerce => 1, + default => sub { HTTP::Headers->new } + ); + +=head1 DESCRIPTION + +This recipe introduces type coercions, which are defined with the +C<coerce> sugar function. Coercions are attached to existing type +constraints, and define a (one-way) transformation from one type to +another. + +This is very powerful, but it can also have unexpected consequences, so +you have to explicitly ask for an attribute to be coerced. To do this, +you must set the C<coerce> attribute option to a true value. + +First, we create the subtype to which we will coerce the other types: + + subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers'); + +We are creating a subtype rather than using C<HTTP::Headers> as a type +directly. The reason we do this is that coercions are global, and a +coercion defined for C<HTTP::Headers> in our C<Request> class would +then be defined for I<all> Moose-using classes in the current Perl +interpreter. It's a L<best practice|Moose::Manual::BestPractices> to +avoid this sort of namespace pollution. + +The C<class_type> sugar function is simply a shortcut for this: + + subtype 'HTTP::Headers' + => as 'Object' + => where { $_->isa('HTTP::Headers') }; + +Internally, Moose creates a type constraint for each Moose-using +class, but for non-Moose classes, the type must be declared +explicitly. + +We could go ahead and use this new type directly: + + has 'headers' => ( + is => 'rw', + isa => 'My::Types::HTTP::Headers', + default => sub { HTTP::Headers->new } + ); + +This creates a simple attribute which defaults to an empty instance of +L<HTTP::Headers>. + +The constructor for L<HTTP::Headers> accepts a list of key-value pairs +representing the HTTP header fields. In Perl, such a list could be +stored in an ARRAY or HASH reference. We want our C<headers> attribute +to accept those data structures instead of an B<HTTP::Headers> +instance, and just do the right thing. This is exactly what coercion +is for: + + coerce 'My::Types::HTTP::Headers' + => from 'ArrayRef' + => via { HTTP::Headers->new( @{$_} ) } + => from 'HashRef' + => via { HTTP::Headers->new( %{$_} ) }; + +The first argument to C<coerce> is the type I<to> which we are +coercing. Then we give it a set of C<from>/C<via> clauses. The C<from> +function takes some other type name and C<via> takes a subroutine +reference which actually does the coercion. + +However, defining the coercion doesn't do anything until we tell Moose +we want a particular attribute to be coerced: + + has 'headers' => ( + is => 'rw', + isa => 'My::Types::HTTP::Headers', + coerce => 1, + default => sub { HTTP::Headers->new } + ); + +Now, if we use an C<ArrayRef> or C<HashRef> to populate C<headers>, it +will be coerced into a new L<HTTP::Headers> instance. With the +coercion in place, the following lines of code are all equivalent: + + $foo->headers( HTTP::Headers->new( bar => 1, baz => 2 ) ); + $foo->headers( [ 'bar', 1, 'baz', 2 ] ); + $foo->headers( { bar => 1, baz => 2 } ); + +As you can see, careful use of coercions can produce a very open +interface for your class, while still retaining the "safety" of your +type constraint checks. (1) + +Our next coercion shows how we can leverage existing CPAN modules to +help implement coercions. In this case we use L<Params::Coerce>. + +Once again, we need to declare a class type for our non-Moose L<URI> +class: + + subtype 'My::Types::URI' => as class_type('URI'); + +Then we define the coercion: + + coerce 'My::Types::URI' + => from 'Object' + => via { $_->isa('URI') + ? $_ + : Params::Coerce::coerce( 'URI', $_ ); } + => from 'Str' + => via { URI->new( $_, 'http' ) }; + +The first coercion takes any object and makes it a C<URI> object. The +coercion system isn't that smart, and does not check if the object is +already a L<URI>, so we check for that ourselves. If it's not a L<URI> +already, we let L<Params::Coerce> do its magic, and we just use its +return value. + +If L<Params::Coerce> didn't return a L<URI> object (for whatever +reason), Moose would throw a type constraint error. + +The other coercion takes a string and converts it to a L<URI>. In this +case, we are using the coercion to apply a default behavior, where a +string is assumed to be an C<http> URI. + +Finally, we need to make sure our attributes enable coercion. + + has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'uri' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + +Re-using the coercion lets us enforce a consistent API across multiple +attributes. + +=for testing-SETUP use Test::Requires { + 'HTTP::Headers' => '0', + 'Params::Coerce' => '0', + 'URI' => '0', +}; + +=head1 CONCLUSION + +This recipe showed the use of coercions to create a more flexible and +DWIM-y API. Like any powerful feature, we recommend some +caution. Sometimes it's better to reject a value than just guess at +how to DWIM. + +We also showed the use of the C<class_type> sugar function as a +shortcut for defining a new subtype of C<Object>. + +=head1 FOOTNOTES + +=over 4 + +=item (1) + +This particular example could be safer. Really we only want to coerce +an array with an I<even> number of elements. We could create a new +C<EvenElementArrayRef> type, and then coerce from that type, as +opposed to a plain C<ArrayRef> + +=back + +=begin testing + +my $r = Request->new; +isa_ok( $r, 'Request' ); + +{ + my $header = $r->headers; + isa_ok( $header, 'HTTP::Headers' ); + + is( $r->headers->content_type, '', + '... got no content type in the header' ); + + $r->headers( { content_type => 'text/plain' } ); + + my $header2 = $r->headers; + isa_ok( $header2, 'HTTP::Headers' ); + isnt( $header, $header2, '... created a new HTTP::Header object' ); + + is( $header2->content_type, 'text/plain', + '... got the right content type in the header' ); + + $r->headers( [ content_type => 'text/html' ] ); + + my $header3 = $r->headers; + isa_ok( $header3, 'HTTP::Headers' ); + isnt( $header2, $header3, '... created a new HTTP::Header object' ); + + is( $header3->content_type, 'text/html', + '... got the right content type in the header' ); + + $r->headers( HTTP::Headers->new( content_type => 'application/pdf' ) ); + + my $header4 = $r->headers; + isa_ok( $header4, 'HTTP::Headers' ); + isnt( $header3, $header4, '... created a new HTTP::Header object' ); + + is( $header4->content_type, 'application/pdf', + '... got the right content type in the header' ); + + isnt( + exception { + $r->headers('Foo'); + }, + undef, + '... dies when it gets bad params' + ); +} + +{ + is( $r->protocol, undef, '... got nothing by default' ); + + is( + exception { + $r->protocol('HTTP/1.0'); + }, + undef, + '... set the protocol correctly' + ); + + is( $r->protocol, 'HTTP/1.0', '... got nothing by default' ); + + isnt( + exception { + $r->protocol('http/1.0'); + }, + undef, + '... the protocol died with bar params correctly' + ); +} + +{ + $r->base('http://localhost/'); + isa_ok( $r->base, 'URI' ); + + $r->uri('http://localhost/'); + isa_ok( $r->uri, 'URI' ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/Immutable.pod b/lib/Moose/Cookbook/Basics/Immutable.pod new file mode 100644 index 0000000..c8dacbd --- /dev/null +++ b/lib/Moose/Cookbook/Basics/Immutable.pod @@ -0,0 +1,99 @@ +# PODNAME: Moose::Cookbook::Basics::Immutable +# ABSTRACT: Making Moose fast by making your class immutable + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::Immutable - Making Moose fast by making your class immutable + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Point; + use Moose; + + has 'x' => ( isa => 'Int', is => 'ro' ); + has 'y' => ( isa => 'Int', is => 'rw' ); + + __PACKAGE__->meta->make_immutable; + +=head1 DESCRIPTION + +The Moose metaclass API provides a C<make_immutable()> method. Calling +this method does two things to your class. First, it makes it +faster. In particular, object construction and destruction are +effectively "inlined" in your class, and no longer invoke the meta +API. + +Second, you can no longer make changes via the metaclass API, such as +adding attributes. In practice, this won't be a problem, as you rarely +need to do this after first loading the class. + +=head1 CONCLUSION + +We strongly recommend you make your classes immutable. It makes your +code much faster, with a small compile-time cost. This will be +especially noticeable when creating many objects. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod b/lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod new file mode 100644 index 0000000..5262d06 --- /dev/null +++ b/lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod @@ -0,0 +1,180 @@ +# PODNAME: Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD +# ABSTRACT: Using BUILDARGS and BUILD to hook into object construction + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD - Using BUILDARGS and BUILD to hook into object construction + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Person; + + has 'ssn' => ( + is => 'ro', + isa => 'Str', + predicate => 'has_ssn', + ); + + has 'country_of_residence' => ( + is => 'ro', + isa => 'Str', + default => 'usa' + ); + + has 'first_name' => ( + is => 'ro', + isa => 'Str', + ); + + has 'last_name' => ( + is => 'ro', + isa => 'Str', + ); + + around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + + if ( @_ == 1 && ! ref $_[0] ) { + return $class->$orig(ssn => $_[0]); + } + else { + return $class->$orig(@_); + } + }; + + sub BUILD { + my $self = shift; + + if ( $self->country_of_residence eq 'usa' ) { + die 'Cannot create a Person who lives in the USA without an ssn.' + unless $self->has_ssn; + } + } + +=head1 DESCRIPTION + +This recipe demonstrates the use of C<BUILDARGS> and C<BUILD>. By +defining these methods, we can hook into the object construction +process without overriding C<new>. + +The C<BUILDARGS> method is called I<before> an object has been +created. It is called as a class method, and receives all of the +parameters passed to the C<new> method. It is expected to do something +with these arguments and return a hash reference. The keys of the hash +must be attribute C<init_arg>s. + +The primary purpose of C<BUILDARGS> is to allow a class to accept +something other than named arguments. In the case of our C<Person> +class, we are allowing it to be called with a single argument, a +social security number: + + my $person = Person->new('123-45-6789'); + +The key part of our C<BUILDARGS> is this conditional: + + if ( @_ == 1 && ! ref $_[0] ) { + return $class->$orig(ssn => $_[0]); + } + +By default, Moose constructors accept a list of key-value pairs, or a +hash reference. We need to make sure that C<$_[0]> is not a reference +before assuming it is a social security number. + +We call the original C<BUILDARGS> method to handle all the other +cases. You should always do this in your own C<BUILDARGS> methods, +since L<Moose::Object> provides its own C<BUILDARGS> method that +handles hash references and a list of key-value pairs. + +The C<BUILD> method is called I<after> the object is constructed, but +before it is returned to the caller. The C<BUILD> method provides an +opportunity to check the object state as a whole. This is a good place +to put logic that cannot be expressed as a type constraint on a single +attribute. + +In the C<Person> class, we need to check the relationship between two +attributes, C<ssn> and C<country_of_residence>. We throw an exception +if the object is not logically consistent. + +=head1 MORE CONSIDERATIONS + +This recipe is made significantly simpler because all of the +attributes are read-only. If the C<country_of_residence> attribute +were settable, we would need to check that a Person had an C<ssn> if +the new country was C<usa>. This could be done with a C<before> +modifier. + +=head1 CONCLUSION + +We have repeatedly discouraged overriding C<new> in Moose +classes. This recipe shows how you can use C<BUILDARGS> and C<BUILD> +to hook into object construction without overriding C<new>. + +The C<BUILDARGS> method lets us expand on Moose's built-in parameter +handling for constructors. The C<BUILD> method lets us implement +logical constraints across the whole object after it is created. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod b/lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod new file mode 100644 index 0000000..25a55aa --- /dev/null +++ b/lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod @@ -0,0 +1,489 @@ +# PODNAME: Moose::Cookbook::Basics::Point_AttributesAndSubclassing +# ABSTRACT: Point and Point3D classes, showing basic attributes and subclassing. + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Basics::Point_AttributesAndSubclassing - Point and Point3D classes, showing basic attributes and subclassing. + +=head1 VERSION + +version 2.1405 + +=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); + }; + + package main; + + # hash or hashrefs are ok for the constructor + my $point1 = Point->new(x => 5, y => 7); + my $point2 = Point->new({x => 5, y => 7}); + + my $point3d = Point3D->new(x => 5, y => 42, z => -5); + +=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<< required => 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>/C<use parent>. 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/recipes/moose_cookbook_basics_point_attributesandsubclassing.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, attributes, +subclassing, and a simple method modifier. + +=head1 FOOTNOTES + +=over 4 + +=item (1) + +Moose provides a number of builtin type constraints, 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 supports 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 glob references - see L<MooseX::GlobRef>). + +=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 + +=begin testing + +my $point = Point->new( x => 1, y => 2 ); +isa_ok( $point, 'Point' ); +isa_ok( $point, 'Moose::Object' ); + +is( $point->x, 1, '... got the right value for x' ); +is( $point->y, 2, '... got the right value for y' ); + +$point->y(10); +is( $point->y, 10, '... got the right (changed) value for y' ); + +isnt( + exception { + $point->y('Foo'); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point->new(); + }, + undef, + '... must provide required attributes to new' +); + +$point->clear(); + +is( $point->x, 0, '... got the right (cleared) value for x' ); +is( $point->y, 0, '... got the right (cleared) value for y' ); + +# check the type constraints on the constructor + +is( + exception { + Point->new( x => 0, y => 0 ); + }, + undef, + '... can assign a 0 to x and y' +); + +isnt( + exception { + Point->new( x => 10, y => 'Foo' ); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point->new( x => 'Foo', y => 10 ); + }, + undef, + '... cannot assign a non-Int to x' +); + +# Point3D + +my $point3d = Point3D->new( { x => 10, y => 15, z => 3 } ); +isa_ok( $point3d, 'Point3D' ); +isa_ok( $point3d, 'Point' ); +isa_ok( $point3d, 'Moose::Object' ); + +is( $point3d->x, 10, '... got the right value for x' ); +is( $point3d->y, 15, '... got the right value for y' ); +is( $point3d->{'z'}, 3, '... got the right value for z' ); + +$point3d->clear(); + +is( $point3d->x, 0, '... got the right (cleared) value for x' ); +is( $point3d->y, 0, '... got the right (cleared) value for y' ); +is( $point3d->z, 0, '... got the right (cleared) value for z' ); + +isnt( + exception { + Point3D->new( x => 10, y => 'Foo', z => 3 ); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point3D->new( x => 'Foo', y => 10, z => 3 ); + }, + undef, + '... cannot assign a non-Int to x' +); + +isnt( + exception { + Point3D->new( x => 0, y => 10, z => 'Bar' ); + }, + undef, + '... cannot assign a non-Int to z' +); + +isnt( + exception { + Point3D->new( x => 10, y => 3 ); + }, + undef, + '... z is a required attribute for Point3D' +); + +# test some class introspection + +can_ok( 'Point', 'meta' ); +isa_ok( Point->meta, 'Moose::Meta::Class' ); + +can_ok( 'Point3D', 'meta' ); +isa_ok( Point3D->meta, 'Moose::Meta::Class' ); + +isnt( + Point->meta, Point3D->meta, + '... they are different metaclasses as well' +); + +# poke at Point + +is_deeply( + [ Point->meta->superclasses ], + ['Moose::Object'], + '... Point got the automagic base class' +); + +my @Point_methods = qw(meta x y clear); +my @Point_attrs = ( 'x', 'y' ); + +is_deeply( + [ sort @Point_methods ], + [ sort Point->meta->get_method_list() ], + '... we match the method list for Point' +); + +is_deeply( + [ sort @Point_attrs ], + [ sort Point->meta->get_attribute_list() ], + '... we match the attribute list for Point' +); + +foreach my $method (@Point_methods) { + ok( Point->meta->has_method($method), + '... Point has the method "' . $method . '"' ); +} + +foreach my $attr_name (@Point_attrs) { + ok( Point->meta->has_attribute($attr_name), + '... Point has the attribute "' . $attr_name . '"' ); + my $attr = Point->meta->get_attribute($attr_name); + ok( $attr->has_type_constraint, + '... Attribute ' . $attr_name . ' has a type constraint' ); + isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); + is( $attr->type_constraint->name, 'Int', + '... Attribute ' . $attr_name . ' has an Int type constraint' ); +} + +# poke at Point3D + +is_deeply( + [ Point3D->meta->superclasses ], + ['Point'], + '... Point3D gets the parent given to it' +); + +my @Point3D_methods = qw( meta z clear ); +my @Point3D_attrs = ('z'); + +is_deeply( + [ sort @Point3D_methods ], + [ sort Point3D->meta->get_method_list() ], + '... we match the method list for Point3D' +); + +is_deeply( + [ sort @Point3D_attrs ], + [ sort Point3D->meta->get_attribute_list() ], + '... we match the attribute list for Point3D' +); + +foreach my $method (@Point3D_methods) { + ok( Point3D->meta->has_method($method), + '... Point3D has the method "' . $method . '"' ); +} + +foreach my $attr_name (@Point3D_attrs) { + ok( Point3D->meta->has_attribute($attr_name), + '... Point3D has the attribute "' . $attr_name . '"' ); + my $attr = Point3D->meta->get_attribute($attr_name); + ok( $attr->has_type_constraint, + '... Attribute ' . $attr_name . ' has a type constraint' ); + isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); + is( $attr->type_constraint->name, 'Int', + '... Attribute ' . $attr_name . ' has an Int type constraint' ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod b/lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod new file mode 100644 index 0000000..af1ba0a --- /dev/null +++ b/lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod @@ -0,0 +1,152 @@ +# PODNAME: Moose::Cookbook::Extending::Debugging_BaseClassRole +# ABSTRACT: Providing a role for the base object class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Extending::Debugging_BaseClassRole - Providing a role for the base object class + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MooseX::Debugging; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + base_class_roles => ['MooseX::Debugging::Role::Object'], + ); + + package MooseX::Debugging::Role::Object; + + use Moose::Role; + + sub BUILD {} + after BUILD => sub { + my $self = shift; + + warn "Made a new " . ( ref $self ) . " object\n"; + }; + +=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 C<S<use +MooseX::Debugging>>, it automatically gets the debugging role applied +to its base object class. + +There are a few pieces of code worth looking at more closely. + + Moose::Exporter->setup_import_methods( + base_class_roles => ['MooseX::Debugging::Role::Object'], + ); + +This creates an C<import> method in the C<MooseX::Debugging> package. Since we +are not actually exporting anything, we do not pass C<setup_import_methods> +any parameters related to exports, but we need to have an C<import> method to +ensure that our C<init_meta> method is called. The C<init_meta> is created by +C<setup_import_methods> for us, since we passed the C<base_class_roles> +parameter. The generated C<init_meta> will in turn call +L<Moose::Util::MetaRole::apply_base_class_roles|Moose::Util::MetaRole/apply_base_class_roles>. + + sub BUILD {} + after BUILD => sub { + ... + }; + +Due to the way role composition currently works, if the class that a role is +composed into contains a C<BUILD> method, then that will override the C<BUILD> +method in any roles it composes, which is typically not what you want. Using a +method modifier on C<BUILD> avoids this issue, since method modifiers compose +together rather than being overridden. Method modifiers require that a method +exists in order to wrap, however, so we also provide a stub method to wrap if +no C<BUILD> method exists in the class. + +=for testing-SETUP use Test::Requires 'Test::Output'; + +=begin testing + +{ + package Debugged; + + use Moose; + MooseX::Debugging->import; +} + +stderr_is( + sub { Debugged->new }, + "Made a new Debugged object\n", + 'got expected output from debugging role' +); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Extending/ExtensionOverview.pod b/lib/Moose/Cookbook/Extending/ExtensionOverview.pod new file mode 100644 index 0000000..2dbd898 --- /dev/null +++ b/lib/Moose/Cookbook/Extending/ExtensionOverview.pod @@ -0,0 +1,404 @@ +# PODNAME: Moose::Cookbook::Extending::ExtensionOverview +# ABSTRACT: Moose extension overview + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Extending::ExtensionOverview - Moose extension overview + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +Moose provides several 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 write Moose extensions without understanding the +metaclasses, and those recipes also demonstrate some basic extension +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, 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 fall into +a few broad categories. + +=head2 Metaclass Extensions + +One way of extending Moose is by extending one or more Moose +metaclasses. For example, in L<Moose::Cookbook::Meta::Table_MetaclassTrait> we saw +a metaclass role 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 role. For example, the L<MooseX::Aliases> module +provides an attribute metaclass trait that lets you specify aliases +to install for methods and attribute accessors. + +A metaclass extension can be packaged as a role/trait or a subclass. If you +can, we recommend using traits instead of subclasses, since it's much easier +to combine disparate traits than 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 Functions + +As part of a metaclass extension, you may also want to provide some +sugar functions, just like L<Moose.pm|Moose> does. Moose provides a +helper module called L<Moose::Exporter> that makes this much +simpler. We will be use L<Moose::Exporter> in several of the extension +recipes. + +=head2 Object Class Extensions + +Another common Moose extension technique is to change the default object +class's behavior. As with metaclass extensions, this can be done with a +role/trait or with a subclass. For example, L<MooseX::StrictConstructor> +extension applies a trait that makes the constructor reject arguments which +don't match its attributes. + +Object class extensions often include metaclass extensions as well. In +particular, if you want your object extension to work when a class is +made immutable, you may need to modify the behavior of some or all of the +L<Moose::Meta::Instance>, L<Moose::Meta::Method::Constructor>, and +L<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 +L<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 MyApp::User; + + use Moose; + + with 'My::Role'; + +Don't use "MooseX" in the name for such packages. + +=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 L<MooseX::Types::URI> and +L<MooseX::Types::DateTime> distributions are two good examples of how +this works. These both build on top of the L<MooseX::Types> extension. + +=head1 ROLES VS TRAITS VS SUBCLASSES + +It is important to understand that B<roles and traits are the same thing>. A +trait is simply a role applied to a instance. The only thing that may +distinguish the two is that a trait can be packaged in a way that lets Moose +resolve a short name to a class name. In other words, with a trait, the caller +can refer to 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::Labeled_AttributeTrait> and +L<Moose::Cookbook::Meta::Table_MetaclassTrait> 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 is 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 +(class) 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) Roles + +Implementing your extensions as metaclass roles makes your extensions +easy to apply, and cooperative with other role-based extensions for +metaclasses. + +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 user's 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. Most +uses of L<Moose::Util::MetaRole> can be handled by L<Moose::Exporter> +directly; see the L<Moose::Exporter> docs. + + package MooseX::Embiggen; + + use Moose::Exporter; + + 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( + class_metaroles => { + class => ['MooseX::Embiggen::Role::Meta::Class'], + attribute => ['MooseX::Embiggen::Role::Meta::Attribute'], + constructor => + ['MooseX::Embiggen::Role::Meta::Method::Constructor'], + }, + base_class_roles => ['MooseX::Embiggen::Role::Object'], + ); + +As you can see from this example, you can use L<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 functions: + + package MooseX::Embiggen; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + with_meta => ['embiggen'], + class_metaroles => { + class => ['MooseX::Embiggen::Role::Meta::Class'], + }, + ); + + sub embiggen { + my $meta = shift; + $meta->embiggen(@_); + } + +And then the consumer of your extension can use your C<embiggen> sub: + + package Consumer; + + use Moose; + use MooseX::Embiggen; + + extends 'Thing'; + + embiggen ...; + +This can be combined with metaclass and base class roles quite easily. + +=head2 More advanced extensions + +Providing your extension simply as a set of traits that gets applied to the +appropriate metaobjects is easy, but sometimes not sufficient. For instance, +sometimes you need to supply not just a base object role, but an actual base +object class (due to needing to interact with existing systems that only +provide a base class). To write extensions like this, you will need to provide +a custom C<init_meta> method in your exporter. For instance: + + package MooseX::Embiggen; + + use Moose::Exporter; + + my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods( + install => ['import', 'unimport'], + with_meta => ['embiggen'], + class_metaroles => { + class => ['MooseX::Embiggen::Role::Meta::Class'], + }, + ); + + sub embiggen { + my $meta = shift; + $meta->embiggen(@_); + } + + sub init_meta { + my $package = shift; + my %options = @_; + if (my $meta = Class::MOP::class_of($options{for_class})) { + if ($meta->isa('Class::MOP::Class')) { + my @supers = $meta->superclasses; + $meta->superclasses('MooseX::Embiggen::Base::Class') + if @supers == 1 && $supers[0] eq 'Moose::Object'; + } + } + $package->$init_meta(%options); + } + +In the previous examples, C<init_meta> was generated for you, but here you must +override it in order to add additional functionality. Some differences to note: + +=over 4 + +=item C<build_import_methods> instead of C<setup_import_methods> + +C<build_import_methods> simply returns the C<import>, C<unimport>, and +C<init_meta> methods, rather than installing them under the appropriate names. +This way, you can write your own methods which wrap the functionality provided +by L<Moose::Exporter>. The C<build_import_methods> sub also takes an +additional C<install> parameter, which tells it to just go ahead and install +these methods (since we don't need to modify them). + +=item C<sub init_meta> + +Next, we must write our C<init_meta> wrapper. The important things to remember +are that it is called as a method, and that C<%options> needs to be passed +through to the existing implementation. We call the base implementation by +using the C<$init_meta> subroutine reference that was returned by +C<build_import_methods> earlier. + +=item Additional implementation + +This extension sets a different default base object class. To do so, it first +checks to see if it's being applied to a class, and then checks to see if +L<Moose::Object> is that class's only superclass, and if so, replaces that with +the superclass that this extension requires. + +Note that two extensions that do this same thing will not work together +properly (the second extension to be loaded won't see L<Moose::Object> as the +base object, since it has already been overridden). This is why using a base +object role is recommended for the general case. + +This C<init_meta> also works defensively, by only applying its functionality if +a metaclass already exists. This makes sure it doesn't break with legacy +extensions which override the metaclass directly (and so must be the first +extension to initialize the metaclass). This is likely not necessary, since +almost no extensions work this way anymore, but just provides an additional +level of protection. The common case of C<use Moose; use MooseX::Embiggen;> +is not affected regardless. + +=back + +This is just one example of what can be done with a custom C<init_meta> method. +It can also be used for preventing an extension from being applied to a role, +doing other kinds of validation on the class being applied to, or pretty much +anything that would otherwise be done in an C<import> method. + +=head1 LEGACY EXTENSION MECHANISMS + +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 L<metaclass.pm|metaclass>, L<Moose::Policy> +(which uses L<metaclass.pm|metaclass> 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. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod b/lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod new file mode 100644 index 0000000..dcc4e90 --- /dev/null +++ b/lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod @@ -0,0 +1,160 @@ +# PODNAME: Moose::Cookbook::Extending::Mooseish_MooseSugar +# ABSTRACT: Acting like Moose.pm and providing sugar Moose-style + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Extending::Mooseish_MooseSugar - Acting like Moose.pm and providing sugar Moose-style + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Mooseish; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + with_meta => ['has_table'], + class_metaroles => { + class => ['MyApp::Meta::Class::Trait::HasTable'], + }, + ); + + sub has_table { + my $meta = shift; + $meta->table(shift); + } + + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + + has table => ( + is => 'rw', + isa => 'Str', + ); + +=head1 DESCRIPTION + +This recipe expands on the use of L<Moose::Exporter> we saw in +L<Moose::Cookbook::Extending::ExtensionOverview> and the class metaclass trait +we saw in L<Moose::Cookbook::Meta::Table_MetaclassTrait>. In this example we +provide our own metaclass trait, and we also export a C<has_table> sugar +function. + +The C<with_meta> parameter specifies a list of functions that should +be wrapped before exporting. The wrapper simply ensures that the +importing package's appropriate metaclass object is the first argument +to the function, so we can do C<S<my $meta = 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 namespace::autoclean; + + use Moose; + use MyApp::Mooseish; + + has_table 'User'; + + has 'username' => ( is => 'ro' ); + has 'password' => ( is => 'ro' ); + + sub login { ... } + +=head1 CONCLUSION + +Providing sugar functions can make your extension look much more +Moose-ish. See L<Fey::ORM> for a more extensive example. + +=begin testing + +{ + package MyApp::User; + + use Moose; + MyApp::Mooseish->import; + + has_table( 'User' ); + + has( 'username' => ( is => 'ro' ) ); + has( 'password' => ( is => 'ro' ) ); + + sub login { } +} + +can_ok( MyApp::User->meta, 'table' ); +is( MyApp::User->meta->table, 'User', + 'MyApp::User->meta->table returns User' ); +ok( MyApp::User->can('username'), + 'MyApp::User has username method' ); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod b/lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod new file mode 100644 index 0000000..521452f --- /dev/null +++ b/lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod @@ -0,0 +1,182 @@ +# PODNAME: Moose::Cookbook::Legacy::Debugging_BaseClassReplacement +# ABSTRACT: Providing an alternate base object class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Legacy::Debugging_BaseClassReplacement - Providing an alternate base object class + +=head1 VERSION + +version 2.1405 + +=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; + return Moose->init_meta( @_, base_class => 'MyApp::Base' ); + } + +=head1 DESCRIPTION + +B<WARNING: Replacing the base class entirely, as opposed to applying roles to +the base class, is strongly discouraged. This recipe is provided solely for +reference when encountering older code that does this.> + +A common extension is to provide an alternate base class. One way to +do that is to make a C<MyApp::Base> and add C<S<extends +'MyApp::Base'>> to every class in your application. That's pretty +tedious. Instead, you can create a 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 think of some +more interesting things to do with your own base class. + +This uses the magic of L<Moose::Exporter>. When we call C<< +Moose::Exporter->setup_import_methods( also => 'Moose' ) >> it builds +C<import> and C<unimport> methods 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. + +=for testing-SETUP use Test::Requires 'Test::Output'; + +=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 CONCLUSION + +This is an awful lot of magic for a simple base class. You will often +want to combine a metaclass trait with a base class extension, and +that's when this technique is useful. + +=begin testing + +{ + package Foo; + + MyApp::UseMyBase->import; + + has( 'size' => ( is => 'rw' ) ); +} + +ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' ); + +ok( Foo->can('size'), 'Foo has a size method' ); + +my $foo; +stderr_like( + sub { $foo = Foo->new( size => 2 ) }, + qr/^Making a new Foo/, + 'got expected warning when calling Foo->new' +); + +is( $foo->size(), 2, '$foo->size is 2' ); + +=end testing + +=head1 AUTHOR + +Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details. + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2012 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod b/lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod new file mode 100644 index 0000000..813b1d9 --- /dev/null +++ b/lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod @@ -0,0 +1,337 @@ +# PODNAME: Moose::Cookbook::Legacy::Labeled_AttributeMetaclass +# ABSTRACT: A meta-attribute, attributes with labels + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Legacy::Labeled_AttributeMetaclass - A meta-attribute, attributes with labels + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Meta::Attribute::Labeled; + use Moose; + extends 'Moose::Meta::Attribute'; + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package Moose::Meta::Attribute::Custom::Labeled; + sub register_implementation {'MyApp::Meta::Attribute::Labeled'} + + package MyApp::Website; + use Moose; + + has url => ( + metaclass => 'Labeled', + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->isa('MyApp::Meta::Attribute::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); + +=head1 SUMMARY + +B<WARNING: Subclassing metaclasses (as opposed to providing metaclass traits) +is strongly discouraged. This recipe is provided solely for reference when +encountering older code that does this.> + +In this recipe, we begin to delve into the wonder of meta-programming. +Some readers may scoff and claim that this is the arena of only the +most twisted Moose developers. Absolutely not! Any sufficiently +twisted developer can benefit greatly from going more meta. + +Our goal is to allow each attribute to have a human-readable "label" +attached to it. Such labels would be used when showing data to an end +user. In this recipe we label the C<url> attribute with "The site's +URL" and create a simple method showing how to use that label. + +The proper, modern way to extend attributes (using a role instead of a +subclass) is described in L<Moose::Cookbook::Meta::Recipe3>, but that recipe +assumes you've read and at least tried to understand this one. + +=head1 META-ATTRIBUTE OBJECTS + +All the attributes of a Moose-based object are actually objects +themselves. These objects have methods and attributes. Let's look at +a concrete example. + + has 'x' => ( isa => 'Int', is => 'ro' ); + has 'y' => ( isa => 'Int', is => 'rw' ); + +Internally, the metaclass for C<Point> has two +L<Moose::Meta::Attribute>. There are several methods for getting +meta-attributes out of a metaclass, one of which is +C<get_attribute_list>. This method is called on the metaclass object. + +The C<get_attribute_list> method returns a list of attribute names. You can +then use C<get_attribute> to get the L<Moose::Meta::Attribute> object itself. + +Once you have this meta-attribute object, you can call methods on it like this: + + print $point->meta->get_attribute('x')->type_constraint; + => Int + +To add a label to our attributes there are two steps. First, we need a +new attribute metaclass that can store a label for an +attribute. Second, we need to create attributes that use that +attribute metaclass. + +=head1 RECIPE REVIEW + +We start by creating a new attribute metaclass. + + package MyApp::Meta::Attribute::Labeled; + use Moose; + extends 'Moose::Meta::Attribute'; + +We can subclass a Moose metaclass in the same way that we subclass +anything else. + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + +Again, this is standard Moose code. + +Then we need to register our metaclass with Moose: + + package Moose::Meta::Attribute::Custom::Labeled; + sub register_implementation { 'MyApp::Meta::Attribute::Labeled' } + +This is a bit of magic that lets us use a short name, "Labeled", when +referring to our new metaclass. + +That was the whole attribute metaclass. + +Now we start using it. + + package MyApp::Website; + use Moose; + use MyApp::Meta::Attribute::Labeled; + +We have to load the metaclass to use it, just like any Perl class. + +Finally, we use it for an attribute: + + has url => ( + metaclass => 'Labeled', + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + +This looks like a normal attribute declaration, except for two things, +the C<metaclass> and C<label> parameters. The C<metaclass> parameter +tells Moose we want to use a custom metaclass for this (one) +attribute. The C<label> parameter will be stored in the meta-attribute +object. + +The reason that we can pass the name C<Labeled>, instead of +C<MyApp::Meta::Attribute::Labeled>, is because of the +C<register_implementation> code we touched on previously. + +When you pass a metaclass to C<has>, it will take the name you provide +and prefix it with C<Moose::Meta::Attribute::Custom::>. Then it calls +C<register_implementation> in the package. In this case, that means +Moose ends up calling +C<Moose::Meta::Attribute::Custom::Labeled::register_implementation>. + +If this function exists, it should return the I<real> metaclass +package name. This is exactly what our code does, returning +C<MyApp::Meta::Attribute::Labeled>. This is a little convoluted, and +if you don't like it, you can always use the fully-qualified name. + +We can access this meta-attribute and its label like this: + + $website->meta->get_attribute('url')->label() + + MyApp::Website->meta->get_attribute('url')->label() + +We also have a regular attribute, C<name>: + + has name => ( + is => 'rw', + isa => 'Str', + ); + +This is a regular Moose attribute, because we have not specified a new +metaclass. + +Finally, we have a C<dump> method, which creates a human-readable +representation of a C<MyApp::Website> object. It will use an +attribute's label if it has one. + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->isa('MyApp::Meta::Attribute::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + +This is a bit of defensive code. We cannot depend on every +meta-attribute having a label. Even if we define one for every +attribute in our class, a subclass may neglect to do so. Or a +superclass could add an attribute without a label. + +We also check that the attribute has a label using the predicate we +defined. We could instead make the label C<required>. If we have a +label, we use it, otherwise we use the attribute name: + + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + +The C<get_read_method> is part of the L<Moose::Meta::Attribute> +API. It returns the name of a method that can read the attribute's +value, I<when called on the real object> (don't call this on the +meta-attribute). + +=head1 CONCLUSION + +You might wonder why you'd bother with all this. You could just +hardcode "The Site's URL" in the C<dump> method. But we want to avoid +repetition. If you need the label once, you may need it elsewhere, +maybe in the C<as_form> method you write next. + +Associating a label with an attribute just makes sense! The label is a +piece of information I<about> the attribute. + +It's also important to realize that this was a trivial example. You +can make much more powerful metaclasses that I<do> things, as opposed +to just storing some more information. For example, you could +implement a metaclass that expires attributes after a certain amount +of time: + + has site_cache => ( + metaclass => 'TimedExpiry', + expires_after => { hours => 1 }, + refresh_with => sub { get( $_[0]->url ) }, + isa => 'Str', + is => 'ro', + ); + +The sky's the limit! + +=for testing my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +is( + $app->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod b/lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod new file mode 100644 index 0000000..e264fea --- /dev/null +++ b/lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod @@ -0,0 +1,132 @@ +# PODNAME: Moose::Cookbook::Legacy::Table_ClassMetaclass +# ABSTRACT: Adding a "table" attribute to the metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Legacy::Table_ClassMetaclass - Adding a "table" attribute to the metaclass + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; + + has table => ( + is => 'rw', + isa => 'Str', + ); + +=head1 DESCRIPTION + +B<WARNING: Subclassing metaclasses (as opposed to providing metaclass traits) +is strongly discouraged. This recipe is provided solely for reference when +encountering older code that does this.> + +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 + +This really is as simple as the recipe L</SYNOPSIS> shows. 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 + +Accessing this new C<table> attribute is quite simple. Given a class +named C<MyApp::User>, we could simply write the following: + + my $table = MyApp::User->meta->table; + +As long as C<MyApp::User> has arranged to use C<MyApp::Meta::Class> as +its metaclass, this method call just works. If we want to be more +careful, we can check the metaclass's class: + + $table = MyApp::User->meta->table + if MyApp::User->meta->isa('MyApp::Meta::Class'); + +=head1 CONCLUSION + +Creating custom metaclass is trivial. Using it is a little harder, and +is covered in other recipes. We will also talk about applying traits +to a class metaclass, which is a more flexible and cooperative +implementation. + +=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 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod b/lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod new file mode 100644 index 0000000..9ca9f68 --- /dev/null +++ b/lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod @@ -0,0 +1,304 @@ +# PODNAME: Moose::Cookbook::Meta::GlobRef_InstanceMetaclass +# ABSTRACT: Creating a glob reference meta-instance class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Meta::GlobRef_InstanceMetaclass - Creating a glob reference meta-instance class + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package My::Meta::Instance; + + use Scalar::Util qw( weaken ); + use Symbol qw( gensym ); + + use Moose::Role; + + sub create_instance { + my $self = shift; + my $sym = gensym(); + bless $sym, $self->_class_name; + } + + sub clone_instance { + my ( $self, $instance ) = @_; + + my $new_sym = gensym(); + %{*$new_sym} = %{*$instance}; + + bless $new_sym, $self->_class_name; + } + + sub get_slot_value { + my ( $self, $instance, $slot_name ) = @_; + return *$instance->{$slot_name}; + } + + sub set_slot_value { + my ( $self, $instance, $slot_name, $value ) = @_; + *$instance->{$slot_name} = $value; + } + + sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + delete *$instance->{$slot_name}; + } + + sub is_slot_initialized { + my ( $self, $instance, $slot_name ) = @_; + exists *$instance->{$slot_name}; + } + + sub weaken_slot_value { + my ( $self, $instance, $slot_name ) = @_; + weaken *$instance->{$slot_name}; + } + + sub inline_create_instance { + my ( $self, $class_variable ) = @_; + return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }'; + } + + sub inline_slot_access { + my ( $self, $instance, $slot_name ) = @_; + return '*{' . $instance . '}->{' . $slot_name . '}'; + } + + package MyApp::User; + + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['My::Meta::Instance'], + }, + ); + + has 'name' => ( + is => 'rw', + isa => 'Str', + ); + + has 'email' => ( + is => 'rw', + isa => 'Str', + ); + +=head1 DESCRIPTION + +This recipe shows how to build your own meta-instance. The meta +instance is the metaclass that creates object instances and helps +manages access to attribute slots. + +In this example, we're creating a meta-instance that is based on a +glob reference rather than a hash reference. This example is largely +based on the Piotr Roszatycki's L<MooseX::GlobRef> module. + +Our extension is a role which will be applied to L<Moose::Meta::Instance>, +which creates hash reference based objects. We need to override all the methods +which make assumptions about the object's data structure. + +The first method we override is C<create_instance>: + + sub create_instance { + my $self = shift; + my $sym = gensym(); + bless $sym, $self->_class_name; + } + +This returns an glob reference which has been blessed into our +meta-instance's associated class. + +We also override C<clone_instance> to create a new array reference: + + sub clone_instance { + my ( $self, $instance ) = @_; + + my $new_sym = gensym(); + %{*$new_sym} = %{*$instance}; + + bless $new_sym, $self->_class_name; + } + +After that, we have a series of methods which mediate access to the +object's slots (attributes are stored in "slots"). In the default +instance class, these expect the object to be a hash reference, but we +need to change this to expect a glob reference instead. + + sub get_slot_value { + my ( $self, $instance, $slot_name ) = @_; + *$instance->{$slot_name}; + } + +This level of indirection probably makes our instance class I<slower> +than the default. However, when attribute access is inlined, this +lookup will be cached: + + sub inline_slot_access { + my ( $self, $instance, $slot_name ) = @_; + return '*{' . $instance . '}->{' . $slot_name . '}'; + } + +The code snippet that the C<inline_slot_access> method returns will +get C<eval>'d once per attribute. + +Finally, we use this meta-instance in our C<MyApp::User> class: + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['My::Meta::Instance'], + }, + ); + +We actually don't recommend the use of L<Moose::Util::MetaRole> directly in +your class in most cases. Typically, this would be provided by a +L<Moose::Exporter>-based module which handles applying the role for you. + +=head1 CONCLUSION + +This recipe shows how to create your own meta-instance class. It's +unlikely that you'll need to do this yourself, but it's interesting to +take a peek at how Moose works under the hood. + +=head1 SEE ALSO + +There are a few meta-instance class extensions on CPAN: + +=over 4 + +=item * L<MooseX::Singleton> + +This module extends the instance class in order to ensure that the +object is a singleton. The instance it uses is still a blessed hash +reference. + +=item * L<MooseX::GlobRef> + +This module makes the instance a blessed glob reference. This lets you +use a handle as an object instance. + +=back + +=begin testing + +{ + package MyApp::Employee; + + use Moose; + extends 'MyApp::User'; + + has 'employee_number' => ( is => 'rw' ); +} + +for my $x ( 0 .. 1 ) { + MyApp::User->meta->make_immutable if $x; + + my $user = MyApp::User->new( + name => 'Faye', + email => 'faye@example.com', + ); + + ok( eval { *{$user} }, 'user object is an glob ref with some values' ); + + is( $user->name, 'Faye', 'check name' ); + is( $user->email, 'faye@example.com', 'check email' ); + + $user->name('Ralph'); + is( $user->name, 'Ralph', 'check name after changing it' ); + + $user->email('ralph@example.com'); + is( $user->email, 'ralph@example.com', 'check email after changing it' ); +} + +for my $x ( 0 .. 1 ) { + MyApp::Employee->meta->make_immutable if $x; + + my $emp = MyApp::Employee->new( + name => 'Faye', + email => 'faye@example.com', + employee_number => $x, + ); + + ok( eval { *{$emp} }, 'employee object is an glob ref with some values' ); + + is( $emp->name, 'Faye', 'check name' ); + is( $emp->email, 'faye@example.com', 'check email' ); + is( $emp->employee_number, $x, 'check employee_number' ); + + $emp->name('Ralph'); + is( $emp->name, 'Ralph', 'check name after changing it' ); + + $emp->email('ralph@example.com'); + is( $emp->email, 'ralph@example.com', 'check email after changing it' ); + + $emp->employee_number(42); + is( $emp->employee_number, 42, 'check employee_number after changing it' ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod b/lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod new file mode 100644 index 0000000..cebe091 --- /dev/null +++ b/lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod @@ -0,0 +1,325 @@ +# PODNAME: Moose::Cookbook::Meta::Labeled_AttributeTrait +# ABSTRACT: Labels implemented via attribute traits + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Meta::Labeled_AttributeTrait - Labels implemented via attribute traits + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Meta::Attribute::Trait::Labeled; + use Moose::Role; + Moose::Util::meta_attribute_alias('Labeled'); + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package MyApp::Website; + use Moose; + + has url => ( + traits => [qw/Labeled/], + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); + +=head1 SUMMARY + +In this recipe, we begin to delve into the wonder of meta-programming. +Some readers may scoff and claim that this is the arena of only the +most twisted Moose developers. Absolutely not! Any sufficiently +twisted developer can benefit greatly from going more meta. + +Our goal is to allow each attribute to have a human-readable "label" +attached to it. Such labels would be used when showing data to an end +user. In this recipe we label the C<url> attribute with "The site's +URL" and create a simple method showing how to use that label. + +=head1 META-ATTRIBUTE OBJECTS + +All the attributes of a Moose-based object are actually objects themselves. +These objects have methods and attributes. Let's look at a concrete example. + + has 'x' => ( isa => 'Int', is => 'ro' ); + has 'y' => ( isa => 'Int', is => 'rw' ); + +Internally, the metaclass for C<Point> has two L<Moose::Meta::Attribute> +objects. There are several methods for getting meta-attributes out of a +metaclass, one of which is C<get_attribute_list>. This method is called on the +metaclass object. + +The C<get_attribute_list> method returns a list of attribute names. You can +then use C<get_attribute> to get the L<Moose::Meta::Attribute> object itself. + +Once you have this meta-attribute object, you can call methods on it like +this: + + print $point->meta->get_attribute('x')->type_constraint; + => Int + +To add a label to our attributes there are two steps. First, we need a new +attribute metaclass trait that can store a label for an attribute. Second, we +need to apply that trait to our attributes. + +=head1 TRAITS + +Roles that apply to metaclasses have a special name: traits. Don't let +the change in nomenclature fool you, B<traits are just roles>. + +L<Moose/has> allows you to pass a C<traits> parameter for an +attribute. This parameter takes a list of trait names which are +composed into an anonymous metaclass, and that anonymous metaclass is +used for the attribute. + +Yes, we still have lots of metaclasses in the background, but they're +managed by Moose for you. + +Traits can do anything roles can do. They can add or refine +attributes, wrap methods, provide more methods, define an interface, +etc. The only difference is that you're now changing the attribute +metaclass instead of a user-level class. + +=head1 DISSECTION + +We start by creating a package for our trait. + + package MyApp::Meta::Attribute::Trait::Labeled; + use Moose::Role; + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + +You can see that a trait is just a L<Moose::Role>. In this case, our role +contains a single attribute, C<label>. Any attribute which does this trait +will now have a label. + +We also register our trait with Moose: + + Moose::Util::meta_attribute_alias('Labeled'); + +This allows Moose to find our trait by the short name C<Labeled> when passed +to the C<traits> attribute option, rather than requiring the full package +name to be specified. + +Finally, we pass our trait when defining an attribute: + + has url => ( + traits => [qw/Labeled/], + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + +The C<traits> parameter contains a list of trait names. Moose will build an +anonymous attribute metaclass from these traits and use it for this +attribute. + +The reason that we can pass the name C<Labeled>, instead of +C<MyApp::Meta::Attribute::Trait::Labeled>, is because of the +C<register_implementation> code we touched on previously. + +When you pass a metaclass to C<has>, it will take the name you provide and +prefix it with C<Moose::Meta::Attribute::Custom::Trait::>. Then it calls +C<register_implementation> in the package. In this case, that means Moose ends +up calling +C<Moose::Meta::Attribute::Custom::Trait::Labeled::register_implementation>. + +If this function exists, it should return the I<real> trait's package +name. This is exactly what our code does, returning +C<MyApp::Meta::Attribute::Trait::Labeled>. This is a little convoluted, and if +you don't like it, you can always use the fully-qualified name. + +We can access this meta-attribute and its label like this: + + $website->meta->get_attribute('url')->label() + + MyApp::Website->meta->get_attribute('url')->label() + +We also have a regular attribute, C<name>: + + has name => ( + is => 'rw', + isa => 'Str', + ); + +Finally, we have a C<dump> method, which creates a human-readable +representation of a C<MyApp::Website> object. It will use an attribute's label +if it has one. + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + +This is a bit of defensive code. We cannot depend on every meta-attribute +having a label. Even if we define one for every attribute in our class, a +subclass may neglect to do so. Or a superclass could add an attribute without +a label. + +We also check that the attribute has a label using the predicate we +defined. We could instead make the label C<required>. If we have a label, we +use it, otherwise we use the attribute name: + + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + +The C<get_read_method> is part of the L<Moose::Meta::Attribute> API. It +returns the name of a method that can read the attribute's value, I<when +called on the real object> (don't call this on the meta-attribute). + +=head1 CONCLUSION + +You might wonder why you'd bother with all this. You could just hardcode "The +Site's URL" in the C<dump> method. But we want to avoid repetition. If you +need the label once, you may need it elsewhere, maybe in the C<as_form> method +you write next. + +Associating a label with an attribute just makes sense! The label is a piece +of information I<about> the attribute. + +It's also important to realize that this was a trivial example. You can make +much more powerful metaclasses that I<do> things, as opposed to just storing +some more information. For example, you could implement a metaclass that +expires attributes after a certain amount of time: + + has site_cache => ( + traits => ['TimedExpiry'], + expires_after => { hours => 1 }, + refresh_with => sub { get( $_[0]->url ) }, + isa => 'Str', + is => 'ro', + ); + +The sky's the limit! + +=for testing my $app + = MyApp::Website->new( url => 'http://google.com', name => 'Google' ); +is( + $app->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod b/lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod new file mode 100644 index 0000000..dab0a38 --- /dev/null +++ b/lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod @@ -0,0 +1,224 @@ +# PODNAME: Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass +# ABSTRACT: A method metaclass for marking methods public or private + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass - A method metaclass for marking methods public or private + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Meta::Method::PrivateOrPublic; + + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Moose::Meta::Method'; + + has '_policy' => ( + is => 'ro', + isa => enum( [ qw( public private ) ] ), + default => 'public', + init_arg => 'policy', + ); + + sub new { + my $class = shift; + my %options = @_; + + my $self = $class->SUPER::wrap(%options); + + $self->{_policy} = $options{policy}; + + $self->_add_policy_wrapper; + + return $self; + } + + sub _add_policy_wrapper { + my $self = shift; + + return if $self->is_public; + + my $name = $self->name; + my $package = $self->package_name; + my $real_body = $self->body; + + my $body = sub { + die "The $package\::$name method is private" + unless ( scalar caller() ) eq $package; + + goto &{$real_body}; + }; + + $self->{body} = $body; + } + + sub is_public { $_[0]->_policy eq 'public' } + sub is_private { $_[0]->_policy eq 'private' } + + package MyApp::User; + + use Moose; + + has 'password' => ( is => 'rw' ); + + __PACKAGE__->meta()->add_method( + '_reset_password', + MyApp::Meta::Method::PrivateOrPublic->new( + name => '_reset_password', + package_name => __PACKAGE__, + body => sub { $_[0]->password('reset') }, + policy => 'private', + ) + ); + +=head1 DESCRIPTION + +This example shows a custom method metaclass that models public versus +private methods. If a method is defined as private, it adds a wrapper +around the method which dies unless it is called from the class where +it was defined. + +The way the method is added to the class is rather ugly. If we wanted +to make this a real feature, we'd probably want to add some sort of +sugar to allow us to declare private methods, but that is beyond the +scope of this recipe. See the Extending recipes for more on this +topic. + +The core of our custom class is the C<policy> attribute, and +C<_add_policy_wrapper> method. + +You'll note that we have to explicitly set the C<policy> attribute in +our constructor: + + $self->{_policy} = $options{policy}; + +That is necessary because Moose metaclasses do not use the meta API to +create objects. Most Moose classes have a custom "inlined" constructor +for speed. + +In this particular case, our parent class's constructor is the C<wrap> +method. We call that to build our object, but it does not include +subclass-specific attributes. + +The C<_add_policy_wrapper> method is where the real work is done. If +the method is private, we construct a wrapper around the real +subroutine which checks that the caller matches the package in which +the subroutine was created. + +If they don't match, it dies. If they do match, the real method is +called. We use C<goto> so that the wrapper does not show up in the +call stack. + +Finally, we replace the value of C<< $self->{body} >>. This is another +case where we have to do something a bit gross because Moose does not +use Moose for its own implementation. + +When we pass this method object to the metaclass's C<add_method> +method, it will take the method body and make it available in the +class. + +Finally, when we retrieve these methods via the introspection API, we +can call the C<is_public> and C<is_private> methods on them to get +more information about the method. + +=head1 SUMMARY + +A custom method metaclass lets us add both behavior and +meta-information to methods. Unfortunately, because the Perl +interpreter does not provide easy hooks into method declaration, the +API we have for adding these methods is not very pretty. + +That can be improved with custom Moose-like sugar, or even by using a +tool like L<Devel::Declare> to create full-blown new keywords in Perl. + +=begin testing + +package main; +use strict; +use warnings; + +use Test::Fatal; + +my $user = MyApp::User->new( password => 'foo!' ); + +like( exception { $user->_reset_password }, +qr/The MyApp::User::_reset_password method is private/, + '_reset_password method dies if called outside MyApp::User class'); + +{ + package MyApp::User; + + sub run_reset { $_[0]->_reset_password } +} + +$user->run_reset; + +is( $user->password, 'reset', 'password has been reset' ); + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod b/lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod new file mode 100644 index 0000000..cf352e7 --- /dev/null +++ b/lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod @@ -0,0 +1,156 @@ +# PODNAME: Moose::Cookbook::Meta::Table_MetaclassTrait +# ABSTRACT: Adding a "table" attribute as a metaclass trait + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Meta::Table_MetaclassTrait - Adding a "table" attribute as a metaclass trait + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + # in lib/MyApp/Meta/Class/Trait/HasTable.pm + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + Moose::Util::meta_class_alias('HasTable'); + + has table => ( + is => 'rw', + isa => 'Str', + ); + + # in lib/MyApp/User.pm + package MyApp::User; + use Moose -traits => 'HasTable'; + + __PACKAGE__->meta->table('User'); + +=head1 DESCRIPTION + +In this recipe, we'll create a class metaclass trait which has a "table" +attribute. This trait 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. + +=begin testing-SETUP + +BEGIN { + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + Moose::Util::meta_class_alias('HasTable'); + + has table => ( + is => 'rw', + isa => 'Str', + ); +} + +=end testing-SETUP + +=head1 THE METACLASS TRAIT + +This really is as simple as the recipe L</SYNOPSIS> shows. 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::Debugging_BaseClassRole>, which shows how to +make a module like C<Moose.pm> itself, with sugar like C<has_table()>. + +=head2 Using this Metaclass Trait in Practice + +Accessing this new C<table> attribute is quite simple. Given a class +named C<MyApp::User>, we could simply write the following: + + my $table = MyApp::User->meta->table; + +As long as C<MyApp::User> has arranged to apply the +C<MyApp::Meta::Class::Trait::HasTable> to its metaclass, this method call just +works. If we want to be more careful, we can check that the class metaclass +object has a C<table> method: + + $table = MyApp::User->meta->table + if MyApp::User->meta->can('table'); + +In theory, this is not entirely correct, since the metaclass might be getting +its C<table> method from a I<different> trait. In practice, you are unlikely +to encounter this sort of problem. + +=head1 RECIPE CAVEAT + +This recipe doesn't work when you paste it all into a single file. This is +because the C<< use Moose -traits => 'HasTable'; >> line ends up being +executed before the C<table> attribute is defined. + +When the two packages are separate files, this just works. + +=head1 SEE ALSO + +L<Moose::Cookbook::Meta::Labeled_AttributeTrait> - Labels implemented via +attribute traits + +=for testing can_ok( MyApp::User->meta, 'table' ); +is( MyApp::User->meta->table, 'User', 'My::User table is User' ); + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Meta/WhyMeta.pod b/lib/Moose/Cookbook/Meta/WhyMeta.pod new file mode 100644 index 0000000..9ea83f3 --- /dev/null +++ b/lib/Moose/Cookbook/Meta/WhyMeta.pod @@ -0,0 +1,117 @@ +# PODNAME: Moose::Cookbook::Meta::WhyMeta +# ABSTRACT: Welcome to the meta world (Why Go Meta?) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Meta::WhyMeta - Welcome to the meta world (Why Go Meta?) + +=head1 VERSION + +version 2.1405 + +=head1 SUMMARY + +You might want to read L<Moose::Manual::MOP> if you haven't done so +yet. + +If you've ever thought "Moose is great, but I wish it did X +differently", then you've gone meta. The meta recipes demonstrate how +to change and extend the way Moose works by extending and overriding +how the meta classes (L<Moose::Meta::Class>, +L<Moose::Meta::Attribute>, etc) work. + +The metaclass API 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 make changes to a class, for +example by adding new methods or attributes. + +The interface presented by L<Moose.pm|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 +create your own Moose variant. + +=head2 Examples + +Let's say that you want to add 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 +recipe shows how to do this using 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 L<MooseX::Aliases> and +L<MooseX::UndefTolerant>. For a more complex example see +L<Fey::ORM> or L<Bread::Board::Declare>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Roles/ApplicationToInstance.pod b/lib/Moose/Cookbook/Roles/ApplicationToInstance.pod new file mode 100644 index 0000000..8a1d07b --- /dev/null +++ b/lib/Moose/Cookbook/Roles/ApplicationToInstance.pod @@ -0,0 +1,191 @@ +# PODNAME: Moose::Cookbook::Roles::ApplicationToInstance +# ABSTRACT: Applying a role to an object instance + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Roles::ApplicationToInstance - Applying a role to an object instance + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Role::Job::Manager; + + use List::Util qw( first ); + + use Moose::Role; + + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]', + ); + + sub assign_work { + my $self = shift; + my $work = shift; + + my $employee = first { !$_->has_work } @{ $self->employees }; + + die 'All my employees have work to do!' unless $employee; + + $employee->work($work); + } + + package main; + + my $lisa = Employee->new( name => 'Lisa' ); + MyApp::Role::Job::Manager->meta->apply($lisa); + + my $homer = Employee->new( name => 'Homer' ); + my $bart = Employee->new( name => 'Bart' ); + my $marge = Employee->new( name => 'Marge' ); + + $lisa->employees( [ $homer, $bart, $marge ] ); + $lisa->assign_work('mow the lawn'); + +=head1 DESCRIPTION + +In this recipe, we show how a role can be applied to an object. In +this specific case, we are giving an employee managerial +responsibilities. + +Applying a role to an object is simple. The L<Moose::Meta::Role> +object provides an C<apply> method. This method will do the right +thing when given an object instance. + + MyApp::Role::Job::Manager->meta->apply($lisa); + +We could also use the C<apply_all_roles> function from L<Moose::Util>. + + apply_all_roles( $person, MyApp::Role::Job::Manager->meta ); + +The main advantage of using C<apply_all_roles> is that it can be used +to apply more than one role at a time. + +We could also pass parameters to the role we're applying: + + MyApp::Role::Job::Manager->meta->apply( + $lisa, + -alias => { assign_work => 'get_off_your_lazy_behind' }, + ); + +We saw examples of how method exclusion and alias working in +L<Moose::Cookbook::Roles::Restartable_AdvancedComposition>. + +=begin testing-SETUP + +{ + # Not in the recipe, but needed for writing tests. + package Employee; + + use Moose; + + has 'name' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + + has 'work' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_work', + ); +} + +=end testing-SETUP + +=head1 CONCLUSION + +Applying a role to an object instance is a useful tool for adding +behavior to existing objects. In our example, it is effective used to +model a promotion. + +It can also be useful as a sort of controlled monkey-patching for +existing code, particularly non-Moose code. For example, you could +create a debugging role and apply it to an object at runtime. + +=begin testing + +{ + my $lisa = Employee->new( name => 'Lisa' ); + MyApp::Role::Job::Manager->meta->apply($lisa); + + my $homer = Employee->new( name => 'Homer' ); + my $bart = Employee->new( name => 'Bart' ); + my $marge = Employee->new( name => 'Marge' ); + + $lisa->employees( [ $homer, $bart, $marge ] ); + $lisa->assign_work('mow the lawn'); + + ok( $lisa->does('MyApp::Role::Job::Manager'), + 'lisa now does the manager role' ); + + is( $homer->work, 'mow the lawn', + 'homer was assigned a task by lisa' ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod b/lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod new file mode 100644 index 0000000..2c59dcf --- /dev/null +++ b/lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod @@ -0,0 +1,379 @@ +# PODNAME: Moose::Cookbook::Roles::Comparable_CodeReuse +# ABSTRACT: Using roles for code reuse + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Roles::Comparable_CodeReuse - Using roles for code reuse + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Eq; + use Moose::Role; + + requires 'equal_to'; + + sub not_equal_to { + my ( $self, $other ) = @_; + not $self->equal_to($other); + } + + package Comparable; + use Moose::Role; + + with 'Eq'; + + requires 'compare'; + + sub equal_to { + my ( $self, $other ) = @_; + $self->compare($other) == 0; + } + + sub greater_than { + my ( $self, $other ) = @_; + $self->compare($other) == 1; + } + + sub less_than { + my ( $self, $other ) = @_; + $self->compare($other) == -1; + } + + sub greater_than_or_equal_to { + my ( $self, $other ) = @_; + $self->greater_than($other) || $self->equal_to($other); + } + + sub less_than_or_equal_to { + my ( $self, $other ) = @_; + $self->less_than($other) || $self->equal_to($other); + } + + package Printable; + use Moose::Role; + + requires 'to_string'; + + package US::Currency; + use Moose; + + with 'Comparable', 'Printable'; + + has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); + + sub compare { + my ( $self, $other ) = @_; + $self->amount <=> $other->amount; + } + + sub to_string { + my $self = shift; + sprintf '$%0.2f USD' => $self->amount; + } + +=head1 DESCRIPTION + +Roles have two primary purposes: as interfaces, and as a means of code +reuse. This recipe demonstrates the latter, with roles that define +comparison and display code for objects. + +Let's start with C<Eq>. First, note that we've replaced C<use Moose> +with C<use Moose::Role>. We also have a new sugar function, C<requires>: + + requires 'equal_to'; + +This says that any class which consumes this role must provide an +C<equal_to> method. It can provide this method directly, or by +consuming some other role. + +The C<Eq> role defines its C<not_equal_to> method in terms of the +required C<equal_to> method. This lets us minimize the methods that +consuming classes must provide. + +The next role, C<Comparable>, builds on the C<Eq> role. We include +C<Eq> in C<Comparable> using C<with>, another new sugar function: + + with 'Eq'; + +The C<with> function takes a list of roles to consume. In our example, +the C<Comparable> role provides the C<equal_to> method required by +C<Eq>. However, it could opt not to, in which case a class that +consumed C<Comparable> would have to provide its own C<equal_to>. In +other words, a role can consume another role I<without> providing any +required methods. + +The C<Comparable> role requires a method, C<compare>: + + requires 'compare'; + +The C<Comparable> role also provides a number of other methods, all of +which ultimately rely on C<compare>. + + sub equal_to { + my ( $self, $other ) = @_; + $self->compare($other) == 0; + } + + sub greater_than { + my ( $self, $other ) = @_; + $self->compare($other) == 1; + } + + sub less_than { + my ( $self, $other ) = @_; + $self->compare($other) == -1; + } + + sub greater_than_or_equal_to { + my ( $self, $other ) = @_; + $self->greater_than($other) || $self->equal_to($other); + } + + sub less_than_or_equal_to { + my ( $self, $other ) = @_; + $self->less_than($other) || $self->equal_to($other); + } + +Finally, we define the C<Printable> role. This role exists solely to +provide an interface. It has no methods, just a list of required methods. +In this case, it just requires a C<to_string> method. + +An interface role is useful because it defines both a method and a +I<name>. We know that any class which does this role has a +C<to_string> method, but we can also assume that this method has the +semantics we want. Presumably, in real code we would define those +semantics in the documentation for the C<Printable> role. (1) + +Finally, we have the C<US::Currency> class which consumes both the +C<Comparable> and C<Printable> roles. + + with 'Comparable', 'Printable'; + +It also defines a regular Moose attribute, C<amount>: + + has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); + +Finally we see the implementation of the methods required by our +roles. We have a C<compare> method: + + sub compare { + my ( $self, $other ) = @_; + $self->amount <=> $other->amount; + } + +By consuming the C<Comparable> role and defining this method, we gain +the following methods for free: C<equal_to>, C<greater_than>, +C<less_than>, C<greater_than_or_equal_to> and +C<less_than_or_equal_to>. + +Then we have our C<to_string> method: + + sub to_string { + my $self = shift; + sprintf '$%0.2f USD' => $self->amount; + } + +=head1 CONCLUSION + +Roles can be very powerful. They are a great way of encapsulating +reusable behavior, as well as communicating (semantic and interface) +information about the methods our classes provide. + +=head1 FOOTNOTES + +=over 4 + +=item (1) + +Consider two classes, C<Runner> and C<Process>, both of which define a +C<run> method. If we just require that an object implements a C<run> +method, we still aren't saying anything about what that method +I<actually does>. If we require an object that implements the +C<Executable> role, we're saying something about semantics. + +=back + +=begin testing + +ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' ); +ok( US::Currency->does('Eq'), '... US::Currency does Eq' ); +ok( US::Currency->does('Printable'), '... US::Currency does Printable' ); + +my $hundred = US::Currency->new( amount => 100.00 ); +isa_ok( $hundred, 'US::Currency' ); + +ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" ); +ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" ); + +can_ok( $hundred, 'amount' ); +is( $hundred->amount, 100, '... got the right amount' ); + +can_ok( $hundred, 'to_string' ); +is( $hundred->to_string, '$100.00 USD', + '... got the right stringified value' ); + +ok( $hundred->does('Comparable'), '... US::Currency does Comparable' ); +ok( $hundred->does('Eq'), '... US::Currency does Eq' ); +ok( $hundred->does('Printable'), '... US::Currency does Printable' ); + +my $fifty = US::Currency->new( amount => 50.00 ); +isa_ok( $fifty, 'US::Currency' ); + +can_ok( $fifty, 'amount' ); +is( $fifty->amount, 50, '... got the right amount' ); + +can_ok( $fifty, 'to_string' ); +is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' ); + +ok( $hundred->greater_than($fifty), '... 100 gt 50' ); +ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' ); +ok( !$hundred->less_than($fifty), '... !100 lt 50' ); +ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' ); +ok( !$hundred->equal_to($fifty), '... !100 eq 50' ); +ok( $hundred->not_equal_to($fifty), '... 100 ne 50' ); + +ok( !$fifty->greater_than($hundred), '... !50 gt 100' ); +ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' ); +ok( $fifty->less_than($hundred), '... 50 lt 100' ); +ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' ); +ok( !$fifty->equal_to($hundred), '... !50 eq 100' ); +ok( $fifty->not_equal_to($hundred), '... 50 ne 100' ); + +ok( !$fifty->greater_than($fifty), '... !50 gt 50' ); +ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' ); +ok( !$fifty->less_than($fifty), '... 50 lt 50' ); +ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' ); +ok( $fifty->equal_to($fifty), '... 50 eq 50' ); +ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' ); + +## ... check some meta-stuff + +# Eq + +my $eq_meta = Eq->meta; +isa_ok( $eq_meta, 'Moose::Meta::Role' ); + +ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' ); +ok( $eq_meta->requires_method('equal_to'), + '... Eq requires_method not_equal_to' ); + +# Comparable + +my $comparable_meta = Comparable->meta; +isa_ok( $comparable_meta, 'Moose::Meta::Role' ); + +ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' ); + +foreach my $method_name ( + qw( + equal_to not_equal_to + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + ) + ) { + ok( $comparable_meta->has_method($method_name), + '... Comparable has_method ' . $method_name ); +} + +ok( $comparable_meta->requires_method('compare'), + '... Comparable requires_method compare' ); + +# Printable + +my $printable_meta = Printable->meta; +isa_ok( $printable_meta, 'Moose::Meta::Role' ); + +ok( $printable_meta->requires_method('to_string'), + '... Printable requires_method to_string' ); + +# US::Currency + +my $currency_meta = US::Currency->meta; +isa_ok( $currency_meta, 'Moose::Meta::Class' ); + +ok( $currency_meta->does_role('Comparable'), + '... US::Currency does Comparable' ); +ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' ); +ok( $currency_meta->does_role('Printable'), + '... US::Currency does Printable' ); + +foreach my $method_name ( + qw( + amount + equal_to not_equal_to + compare + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + to_string + ) + ) { + ok( $currency_meta->has_method($method_name), + '... US::Currency has_method ' . $method_name ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod b/lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod new file mode 100644 index 0000000..53069a2 --- /dev/null +++ b/lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod @@ -0,0 +1,230 @@ +# PODNAME: Moose::Cookbook::Roles::Restartable_AdvancedComposition +# ABSTRACT: Advanced Role Composition - method exclusion and aliasing + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Roles::Restartable_AdvancedComposition - Advanced Role Composition - method exclusion and aliasing + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Restartable; + use Moose::Role; + + has 'is_paused' => ( + is => 'rw', + isa => 'Bool', + default => 0, + ); + + requires 'save_state', 'load_state'; + + sub stop { 1 } + + sub start { 1 } + + package Restartable::ButUnreliable; + use Moose::Role; + + with 'Restartable' => { + -alias => { + stop => '_stop', + start => '_start' + }, + -excludes => [ 'stop', 'start' ], + }; + + sub stop { + my $self = shift; + + $self->explode() if rand(1) > .5; + + $self->_stop(); + } + + sub start { + my $self = shift; + + $self->explode() if rand(1) > .5; + + $self->_start(); + } + + package Restartable::ButBroken; + use Moose::Role; + + with 'Restartable' => { -excludes => [ 'stop', 'start' ] }; + + sub stop { + my $self = shift; + + $self->explode(); + } + + sub start { + my $self = shift; + + $self->explode(); + } + +=head1 DESCRIPTION + +In this example, we demonstrate how to exercise fine-grained control +over what methods we consume from a role. We have a C<Restartable> +role which provides an C<is_paused> attribute, and two methods, +C<stop> and C<start>. + +Then we have two more roles which implement the same interface, each +putting their own spin on the C<stop> and C<start> methods. + +In the C<Restartable::ButUnreliable> role, we want to provide a new +implementation of C<stop> and C<start>, but still have access to the +original implementation. To do this, we alias the methods from +C<Restartable> to private methods, and provide wrappers around the +originals (1). + +Note that aliasing simply I<adds> a name, so we also need to exclude the +methods with their original names. + + with 'Restartable' => { + -alias => { + stop => '_stop', + start => '_start' + }, + -excludes => [ 'stop', 'start' ], + }; + +In the C<Restartable::ButBroken> role, we want to provide an entirely +new behavior for C<stop> and C<start>. We exclude them entirely when +composing the C<Restartable> role into C<Restartable::ButBroken>. + +It's worth noting that the C<-excludes> parameter also accepts a single +string as an argument if you just want to exclude one method. + + with 'Restartable' => { -excludes => [ 'stop', 'start' ] }; + +=head1 CONCLUSION + +Exclusion and renaming are a power tool that can be handy, especially +when building roles out of other roles. In this example, all of our +roles implement the C<Restartable> role. Each role provides same API, +but each has a different implementation under the hood. + +You can also use the method aliasing and excluding features when +composing a role into a class. + +=head1 FOOTNOTES + +=over 4 + +=item (1) + +The mention of wrapper should tell you that we could do the same thing +using method modifiers, but for the sake of this example, we don't. + +=back + +=begin testing + +{ + my $unreliable = Moose::Meta::Class->create_anon_class( + superclasses => [], + roles => [qw/Restartable::ButUnreliable/], + methods => { + explode => sub { }, # nop. + 'save_state' => sub { }, + 'load_state' => sub { }, + }, + )->new_object(); + ok( $unreliable, 'made anon class with Restartable::ButUnreliable role' ); + can_ok( $unreliable, qw/start stop/ ); +} + +{ + my $cnt = 0; + my $broken = Moose::Meta::Class->create_anon_class( + superclasses => [], + roles => [qw/Restartable::ButBroken/], + methods => { + explode => sub { $cnt++ }, + 'save_state' => sub { }, + 'load_state' => sub { }, + }, + )->new_object(); + + ok( $broken, 'made anon class with Restartable::ButBroken role' ); + + $broken->start(); + + is( $cnt, 1, '... start called explode' ); + + $broken->stop(); + + is( $cnt, 2, '... stop also called explode' ); +} + +=end testing + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Snack/Keywords.pod b/lib/Moose/Cookbook/Snack/Keywords.pod new file mode 100644 index 0000000..a79cc57 --- /dev/null +++ b/lib/Moose/Cookbook/Snack/Keywords.pod @@ -0,0 +1,240 @@ +# PODNAME: Moose::Cookbook::Snack::Keywords +# ABSTRACT: Restricted "keywords" in Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Snack::Keywords - Restricted "keywords" in Moose + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +Moose exports a number of sugar functions in order to emulate Perl +built-in keywords. These can cause clashes with other user-defined +functions. This document provides a list of those keywords for easy +reference. + +=head2 The 'meta' keyword + +C<S<use Moose>> adds a method called C<meta> to your class. If this +conflicts with a method or function you are using, you can rename it, +or prevent it from being installed entirely. To do this, pass the +C<-meta_name> option when you C<S<use Moose>>. For instance: + + # install it under a different name + use Moose -meta_name => 'moose_meta'; + + # don't install it at all + use Moose -meta_name => undef; + +=head2 Moose Keywords + +If you are using L<Moose> or L<Moose::Role> it is best to avoid these +keywords: + +=over 4 + +=item extends + +=item with + +=item has + +=item before + +=item after + +=item around + +=item super + +=item override + +=item inner + +=item augment + +=item confess + +=item blessed + +=item meta + +=back + +=head2 Moose::Util::TypeConstraints Keywords + +If you are using L<Moose::Util::TypeConstraints> it is best to avoid +these keywords: + +=over 4 + +=item type + +=item subtype + +=item class_type + +=item role_type + +=item maybe_type + +=item duck_type + +=item as + +=item where + +=item message + +=item inline_as + +=item coerce + +=item from + +=item via + +=item enum + +=item find_type_constraint + +=item register_type_constraint + +=back + +=head2 Avoiding collisions + +=head3 Turning off Moose + +To remove the sugar functions L<Moose> exports, just add C<S<no Moose>> +at the bottom of your code: + + package Thing; + use Moose; + + # code here + + no Moose; + +This will unexport the sugar functions that L<Moose> originally +exported. The same will also work for L<Moose::Role> and +L<Moose::Util::TypeConstraints>. + +=head3 Sub::Exporter features + +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. + +For instance, with L<Sub::Exporter> you can rename keywords, like so: + + 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'); + +See the L<Sub::Exporter> docs for more information. + +=head3 namespace::autoclean and namespace::clean + +You can also use L<namespace::autoclean> to clean up your namespace. +This will remove all imported functions from your namespace. Note +that if you are importing functions that are intended to be used as +methods (this includes L<overload>, due to internal implementation +details), it will remove these as well. + +Another option is to use L<namespace::clean> directly, but +you must be careful not to remove C<meta> when doing so: + + package Foo; + use Moose; + use namespace::clean -except => 'meta'; + # ... + +=head1 SEE ALSO + +=over 4 + +=item L<Moose> + +=item L<Moose::Role> + +=item L<Moose::Util::TypeConstraints> + +=item L<Sub::Exporter> + +=item L<namespace::autoclean> + +=item L<namespace::clean> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Snack/Types.pod b/lib/Moose/Cookbook/Snack/Types.pod new file mode 100644 index 0000000..44f9b5b --- /dev/null +++ b/lib/Moose/Cookbook/Snack/Types.pod @@ -0,0 +1,130 @@ +# PODNAME: Moose::Cookbook::Snack::Types +# ABSTRACT: Snippets of code for using Types and Type Constraints + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Snack::Types - Snippets of code for using Types and Type Constraints + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Point; + use Moose; + + has 'x' => ( isa => 'Int', is => 'ro' ); + has 'y' => ( isa => 'Int', is => 'rw' ); + + package main; + use Try::Tiny; + + my $point = try { + Point->new( x => 'fifty', y => 'forty' ); + } + catch { + print "Oops: $_"; + }; + + my $point; + my $xval = 'forty-two'; + my $xattribute = Point->meta->find_attribute_by_name('x'); + my $xtype_constraint = $xattribute->type_constraint; + + if ( $xtype_constraint->check($xval) ) { + $point = Point->new( x => $xval, y => 0 ); + } + else { + print "Value: $xval is not an " . $xtype_constraint->name . "\n"; + } + +=head1 DESCRIPTION + +This is the Point example from +L<Moose::Cookbook::Basics::Point_AttributesAndSubclassing> with type checking +added. + +If we try to assign a string value to an attribute that is an C<Int>, +Moose will die with an explicit error message. The error will include +the attribute name, as well as the type constraint name and the value +which failed the constraint check. + +We use L<Try::Tiny> to catch this error message. + +Later, we get the L<Moose::Meta::TypeConstraint> object from a +L<Moose::Meta::Attribute> and use the L<Moose::Meta::TypeConstraint> +to check a value directly. + +=head1 SEE ALSO + +=over 4 + +=item L<Moose::Cookbook::Basics::Point_AttributesAndSubclassing> + +=item L<Moose::Util::TypeConstraints> + +=item L<Moose::Meta::Attribute> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Cookbook/Style.pod b/lib/Moose/Cookbook/Style.pod new file mode 100644 index 0000000..be9334b --- /dev/null +++ b/lib/Moose/Cookbook/Style.pod @@ -0,0 +1,77 @@ +# PODNAME: Moose::Cookbook::Style +# ABSTRACT: Expanded into Moose::Manual::BestPractices, so go read that + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Cookbook::Style - Expanded into Moose::Manual::BestPractices, so go read that + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The style cookbook has been replaced by +L<Moose::Manual::BestPractices>. This POD document still exists for +the benefit of anyone out there who might've linked to it in the past. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Deprecated.pm b/lib/Moose/Deprecated.pm new file mode 100644 index 0000000..cc7e2c0 --- /dev/null +++ b/lib/Moose/Deprecated.pm @@ -0,0 +1,98 @@ +package Moose::Deprecated; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Package::DeprecationManager 0.07 -deprecations => { + 'non-arrayref form of enum' => '2.1100', + 'non-arrayref form of duck_type' => '2.1100', + }, + -ignore => [qr/^(?:Class::MOP|Moose)(?:::)?/], + ; + +1; + +# ABSTRACT: Manages deprecation warnings for Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Deprecated - Manages deprecation warnings for Moose + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + + use Moose::Deprecated -api_version => $version; + +=head1 FUNCTIONS + +This module manages deprecation warnings for features that have been +deprecated in Moose. + +If you specify C<< -api_version => $version >>, you can use deprecated features +without warnings. Note that this special treatment is limited to the package +that loads C<Moose::Deprecated>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Exception.pm b/lib/Moose/Exception.pm new file mode 100644 index 0000000..b52c9d8 --- /dev/null +++ b/lib/Moose/Exception.pm @@ -0,0 +1,206 @@ +package Moose::Exception; +our $VERSION = '2.1405'; + +use Moose; +use Devel::StackTrace 1.33; + +has 'trace' => ( + is => 'ro', + isa => 'Devel::StackTrace', + builder => '_build_trace', + lazy => 1, + documentation => "This attribute is read-only and isa L<Devel::StackTrace>. ". + 'It is lazy & dependent on $exception->message.' +); + +has 'message' => ( + is => 'ro', + isa => 'Str', + builder => '_build_message', + lazy => 1, + documentation => "This attribute is read-only and isa Str. ". + "It is lazy and has a default value 'Error'." +); + +use overload( + q{""} => 'as_string', + fallback => 1, +); + +sub _build_trace { + my $self = shift; + + # skip frames that are method calls on the exception object, which include + # the object itself in the arguments (but Devel::LeakTrace really ought to + # be weakening all references in its frames) + my $skip = 0; + while (my @c = caller(++$skip)) { + last if $c[3] =~ /^(.*)::new$/ && $self->isa($1); + } + $skip++; + + Devel::StackTrace->new( + message => $self->message, + indent => 1, + skip_frames => $skip, + no_refs => 1, + ); +} + +sub _build_message { + "Error"; +} + +sub BUILD { + my $self = shift; + $self->trace; +} + +sub as_string { + my $self = shift; + + if ( $ENV{MOOSE_FULL_EXCEPTION} ) { + return $self->trace->as_string; + } + + my @frames; + my $last_frame; + my $in_moose = 1; + for my $frame ( $self->trace->frames ) { + if ( $in_moose && $frame->package =~ /^(?:Moose|Class::MOP)(?::|$)/ ) + { + $last_frame = $frame; + next; + } + elsif ($last_frame) { + push @frames, $last_frame; + undef $last_frame; + } + + $in_moose = 0; + push @frames, $frame; + } + + # This would be a somewhat pathological case, but who knows + return $self->trace->as_string unless @frames; + + my $message = ( shift @frames )->as_string( 1, {} ) . "\n"; + $message .= join q{}, map { $_->as_string( 0, {} ) . "\n" } @frames; + + return $message; +} + +1; + +# ABSTRACT: Superclass for Moose internal exceptions + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Exception - Superclass for Moose internal exceptions + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class contains attributes which are common to all Moose internal +exception classes. + +=head1 WARNING WARNING WARNING + +If you're writing your own exception classes, you should instead prefer +the L<Throwable> role or the L<Throwable::Error> superclass - this is +effectively a cut-down internal fork of the latter, and not designed +for use in user code. + +Of course if you're writing metaclass traits, it would then make sense to +subclass the relevant Moose exceptions - but only then. + +=head1 METHODS + +This class provides the following methods: + +=head2 $exception->message + +This methods returns the exception message. + +=head2 $exception->trace + +This method returns the stack trace for the given exception. + +=head2 $exception->as_string + +This method returns a stringified form of the exception, including a stack +trace. By default, this method skips Moose-internal stack frames until it sees +a caller outside of the Moose core. If the C<MOOSE_FULL_EXCEPTION> environment +variable is true, these frames are included. + +=head1 SEE ALSO + +=over 4 + +=item * L<Moose::Manual::Exceptions> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Exception/AccessorMustReadWrite.pm b/lib/Moose/Exception/AccessorMustReadWrite.pm new file mode 100644 index 0000000..d33d928 --- /dev/null +++ b/lib/Moose/Exception/AccessorMustReadWrite.pm @@ -0,0 +1,13 @@ +package Moose::Exception::AccessorMustReadWrite; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "Cannot define an accessor name on a read-only attribute, accessors are read/write"; +} + +1; diff --git a/lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm b/lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm new file mode 100644 index 0000000..8bd52f8 --- /dev/null +++ b/lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm @@ -0,0 +1,18 @@ +package Moose::Exception::AddParameterizableTypeTakesParameterizableType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'type_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Type must be a Moose::Meta::TypeConstraint::Parameterizable not ".$self->type_name; +} + +1; diff --git a/lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm b/lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm new file mode 100644 index 0000000..b3ca1f3 --- /dev/null +++ b/lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::AddRoleTakesAMooseMetaRoleInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'role_to_be_added' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + "Roles must be instances of Moose::Meta::Role"; +} + +1; diff --git a/lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm b/lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm new file mode 100644 index 0000000..98a72ab --- /dev/null +++ b/lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm @@ -0,0 +1,18 @@ +package Moose::Exception::AddRoleToARoleTakesAMooseMetaRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'role_to_be_added' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + "Roles must be instances of Moose::Meta::Role"; +} + +1; diff --git a/lib/Moose/Exception/ApplyTakesABlessedInstance.pm b/lib/Moose/Exception/ApplyTakesABlessedInstance.pm new file mode 100644 index 0000000..fa65f79 --- /dev/null +++ b/lib/Moose/Exception/ApplyTakesABlessedInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::ApplyTakesABlessedInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'param' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + "You must pass in an blessed instance"; +} + +1; diff --git a/lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm b/lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm new file mode 100644 index 0000000..f944577 --- /dev/null +++ b/lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm @@ -0,0 +1,18 @@ +package Moose::Exception::AttachToClassNeedsAClassMOPClassInstanceOrASubclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'class' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "You must pass a Class::MOP::Class instance (or a subclass)"; +} + +1; diff --git a/lib/Moose/Exception/AttributeConflictInRoles.pm b/lib/Moose/Exception/AttributeConflictInRoles.pm new file mode 100644 index 0000000..00d7b56 --- /dev/null +++ b/lib/Moose/Exception/AttributeConflictInRoles.pm @@ -0,0 +1,31 @@ +package Moose::Exception::AttributeConflictInRoles; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'second_role_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $role_name = $self->role_name; + my $second_role_name = $self->second_role_name; + my $attribute_name = $self->attribute_name; + "Role '$role_name' has encountered an attribute conflict" + . " while being composed into '$second_role_name'." + . " This is a fatal error and cannot be disambiguated." + . " The conflicting attribute is named '$attribute_name'."; +} + +1; diff --git a/lib/Moose/Exception/AttributeConflictInSummation.pm b/lib/Moose/Exception/AttributeConflictInSummation.pm new file mode 100644 index 0000000..81ba5b7 --- /dev/null +++ b/lib/Moose/Exception/AttributeConflictInSummation.pm @@ -0,0 +1,27 @@ +package Moose::Exception::AttributeConflictInSummation; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role', 'Moose::Exception::Role::AttributeName'; + +has 'second_role_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + + my $role1 = $self->role_name; + my $role2 = $self->second_role_name; + my $attr_name = $self->attribute_name; + + return "We have encountered an attribute conflict with '$attr_name'" + . " during role composition. " + . " This attribute is defined in both $role1 and $role2." + . " This is a fatal error and cannot be disambiguated."; +} + +1; diff --git a/lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm b/lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm new file mode 100644 index 0000000..8face5c --- /dev/null +++ b/lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm @@ -0,0 +1,18 @@ +package Moose::Exception::AttributeExtensionIsNotSupportedInRoles; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + "has '+attr' is not supported in roles"; +} + +1; diff --git a/lib/Moose/Exception/AttributeIsRequired.pm b/lib/Moose/Exception/AttributeIsRequired.pm new file mode 100644 index 0000000..fa852dd --- /dev/null +++ b/lib/Moose/Exception/AttributeIsRequired.pm @@ -0,0 +1,28 @@ +package Moose::Exception::AttributeIsRequired; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1, + documentation => "This attribute can be used for fetching attribute instance:\n". + " my \$class = Moose::Util::find_meta( \$exception->class_name );\n". + " my \$attribute = \$class->get_attribute( \$exception->attribute_name );\n", +); + +has 'params' => ( + is => 'ro', + isa => 'HashRef', + predicate => 'has_params', +); + +sub _build_message { + my $self = shift; + "Attribute (".$self->attribute_name.") is required"; +} + +1; diff --git a/lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm b/lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm new file mode 100644 index 0000000..8f89d97 --- /dev/null +++ b/lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm @@ -0,0 +1,18 @@ +package Moose::Exception::AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'attribute' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)"; +} + +1; diff --git a/lib/Moose/Exception/AttributeNamesDoNotMatch.pm b/lib/Moose/Exception/AttributeNamesDoNotMatch.pm new file mode 100644 index 0000000..4510eed --- /dev/null +++ b/lib/Moose/Exception/AttributeNamesDoNotMatch.pm @@ -0,0 +1,24 @@ +package Moose::Exception::AttributeNamesDoNotMatch; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has attribute_name => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +has attribute => ( + is => 'ro', + isa => 'Class::MOP::Attribute', + required => 1, +); + +sub _build_message { + my $self = shift; + "attribute_name (".$self-> attribute_name.") does not match attribute->name (".$self->attribute->name.")"; +} + +1; diff --git a/lib/Moose/Exception/AttributeValueIsNotAnObject.pm b/lib/Moose/Exception/AttributeValueIsNotAnObject.pm new file mode 100644 index 0000000..523a4a9 --- /dev/null +++ b/lib/Moose/Exception/AttributeValueIsNotAnObject.pm @@ -0,0 +1,27 @@ +package Moose::Exception::AttributeValueIsNotAnObject; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance', 'Moose::Exception::Role::Attribute'; + +has 'method' => ( + is => 'ro', + isa => 'Moose::Meta::Method::Delegation', + required => 1, +); + +has 'given_value' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + my $self = shift; + "Cannot delegate ".$self->method->name." to " + .$self->method->delegate_to_method." because the value of " + . $self->attribute->name . " is not an object (got '".$self->given_value."')"; +} + +1; diff --git a/lib/Moose/Exception/AttributeValueIsNotDefined.pm b/lib/Moose/Exception/AttributeValueIsNotDefined.pm new file mode 100644 index 0000000..95555a6 --- /dev/null +++ b/lib/Moose/Exception/AttributeValueIsNotDefined.pm @@ -0,0 +1,21 @@ +package Moose::Exception::AttributeValueIsNotDefined; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance', 'Moose::Exception::Role::Attribute'; + +has 'method' => ( + is => 'ro', + isa => 'Moose::Meta::Method::Delegation', + required => 1, +); + +sub _build_message { + my $self = shift; + "Cannot delegate ".$self->method->name." to " + .$self->method->delegate_to_method." because the value of " + . $self->attribute->name . " is not defined"; +} + +1; diff --git a/lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm b/lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm new file mode 100644 index 0000000..ef32986 --- /dev/null +++ b/lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm @@ -0,0 +1,13 @@ +package Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/BadOptionFormat.pm b/lib/Moose/Exception/BadOptionFormat.pm new file mode 100644 index 0000000..cccee33 --- /dev/null +++ b/lib/Moose/Exception/BadOptionFormat.pm @@ -0,0 +1,24 @@ +package Moose::Exception::BadOptionFormat; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'option_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'option_value' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; +} + +1; diff --git a/lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm b/lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm new file mode 100644 index 0000000..022268d --- /dev/null +++ b/lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm @@ -0,0 +1,18 @@ +package Moose::Exception::BothBuilderAndDefaultAreNotAllowed; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "Setting both default and builder is not allowed."; +} + +1; diff --git a/lib/Moose/Exception/BuilderDoesNotExist.pm b/lib/Moose/Exception/BuilderDoesNotExist.pm new file mode 100644 index 0000000..6629352 --- /dev/null +++ b/lib/Moose/Exception/BuilderDoesNotExist.pm @@ -0,0 +1,13 @@ +package Moose::Exception::BuilderDoesNotExist; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute', 'Moose::Exception::Role::Instance'; + +sub _build_message { + my $self = shift; + blessed($self->instance)." does not support builder method '".$self->attribute->builder."' for attribute '".$self->attribute->name."'"; +} + +1; diff --git a/lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm b/lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm new file mode 100644 index 0000000..648d50c --- /dev/null +++ b/lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm @@ -0,0 +1,13 @@ +package Moose::Exception::BuilderMethodNotSupportedForAttribute; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute', 'Moose::Exception::Role::Instance'; + +sub _build_message { + my $self = shift; + blessed($self->instance)." does not support builder method '". $self->attribute->builder ."' for attribute '" . $self->attribute->name . "'"; +} + +1; diff --git a/lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm b/lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm new file mode 100644 index 0000000..9757e65 --- /dev/null +++ b/lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm @@ -0,0 +1,25 @@ +package Moose::Exception::BuilderMethodNotSupportedForInlineAttribute; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance', 'Moose::Exception::Role::Class'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'builder' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + $self->class_name." does not support builder method '". $self->builder ."' for attribute '" . $self->attribute_name . "'"; +} + +1; diff --git a/lib/Moose/Exception/BuilderMustBeAMethodName.pm b/lib/Moose/Exception/BuilderMustBeAMethodName.pm new file mode 100644 index 0000000..967ba5f --- /dev/null +++ b/lib/Moose/Exception/BuilderMustBeAMethodName.pm @@ -0,0 +1,18 @@ +package Moose::Exception::BuilderMustBeAMethodName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "builder must be a defined scalar value which is a method name"; +} + +1; diff --git a/lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm b/lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm new file mode 100644 index 0000000..6ac2d37 --- /dev/null +++ b/lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::CallingMethodOnAnImmutableInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "The '".$self->method_name."' method cannot be called on an immutable instance"; +} + +1; diff --git a/lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm b/lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm new file mode 100644 index 0000000..e880935 --- /dev/null +++ b/lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::CallingReadOnlyMethodOnAnImmutableInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "The '".$self->method_name."' method is read-only when called on an immutable instance"; +} + +1; diff --git a/lib/Moose/Exception/CanExtendOnlyClasses.pm b/lib/Moose/Exception/CanExtendOnlyClasses.pm new file mode 100644 index 0000000..9519aed --- /dev/null +++ b/lib/Moose/Exception/CanExtendOnlyClasses.pm @@ -0,0 +1,14 @@ +package Moose::Exception::CanExtendOnlyClasses; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +sub _build_message { + my $self = shift; + my $role_name = $self->role_name; + return "You cannot inherit from a Moose Role ($role_name)"; +} + +1; diff --git a/lib/Moose/Exception/CanOnlyConsumeRole.pm b/lib/Moose/Exception/CanOnlyConsumeRole.pm new file mode 100644 index 0000000..3cc7288 --- /dev/null +++ b/lib/Moose/Exception/CanOnlyConsumeRole.pm @@ -0,0 +1,17 @@ +package Moose::Exception::CanOnlyConsumeRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'role_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "You can only consume roles, ".$self->role_name." is not a Moose role"; +} +1; diff --git a/lib/Moose/Exception/CanOnlyWrapBlessedCode.pm b/lib/Moose/Exception/CanOnlyWrapBlessedCode.pm new file mode 100644 index 0000000..997b39e --- /dev/null +++ b/lib/Moose/Exception/CanOnlyWrapBlessedCode.pm @@ -0,0 +1,24 @@ +package Moose::Exception::CanOnlyWrapBlessedCode; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'code' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "Can only wrap blessed CODE"; +} + +1; diff --git a/lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm b/lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm new file mode 100644 index 0000000..fbc216c --- /dev/null +++ b/lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm @@ -0,0 +1,14 @@ +package Moose::Exception::CanReblessOnlyIntoASubclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash', 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Instance', 'Moose::Exception::Role::InstanceClass'; + +sub _build_message { + my $self = shift; + my $instance_class = $self->instance_class; + "You may rebless only into a subclass of ($instance_class), of which (". $self->class_name .") isn't." +} + +1; diff --git a/lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm b/lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm new file mode 100644 index 0000000..b164381 --- /dev/null +++ b/lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CanReblessOnlyIntoASuperclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Instance', 'Moose::Exception::Role::InstanceClass'; + +sub _build_message { + my $self = shift; + "You may rebless only into a superclass of (".blessed( $self->instance )."), of which (". $self->class_name .") isn't." +} + +1; diff --git a/lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm b/lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm new file mode 100644 index 0000000..7edba0f --- /dev/null +++ b/lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm @@ -0,0 +1,17 @@ +package Moose::Exception::CannotAddAdditionalTypeCoercionsToUnion; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'type_coercion_union_object' => ( + is => 'ro', + isa => 'Moose::Meta::TypeCoercion::Union', + required => 1 +); + +sub _build_message { + return "Cannot add additional type coercions to Union types"; +} + +1; diff --git a/lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm b/lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm new file mode 100644 index 0000000..960d56c --- /dev/null +++ b/lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm @@ -0,0 +1,19 @@ +package Moose::Exception::CannotAddAsAnAttributeToARole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'attribute_class' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "Cannot add a ".$self->attribute_class." as an attribute to a role"; +} + +1; diff --git a/lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm b/lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm new file mode 100644 index 0000000..d38630a --- /dev/null +++ b/lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CannotApplyBaseClassRolesToRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash', 'Moose::Exception::Role::Role'; + +sub _build_message { + "You can only apply base class roles to a Moose class, not a role."; +} + +1; diff --git a/lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm b/lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm new file mode 100644 index 0000000..37195a8 --- /dev/null +++ b/lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm @@ -0,0 +1,19 @@ +package Moose::Exception::CannotAssignValueToReadOnlyAccessor; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::EitherAttributeOrAttributeName'; + +has 'value' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + "Cannot assign a value to a read-only accessor"; +} + +1; diff --git a/lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm b/lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm new file mode 100644 index 0000000..6a3339e --- /dev/null +++ b/lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CannotAugmentIfLocalMethodPresent; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Method'; + +sub _build_message { + "Cannot add an augment method if a local method is already present"; +} + +1; diff --git a/lib/Moose/Exception/CannotAugmentNoSuperMethod.pm b/lib/Moose/Exception/CannotAugmentNoSuperMethod.pm new file mode 100644 index 0000000..5f36249 --- /dev/null +++ b/lib/Moose/Exception/CannotAugmentNoSuperMethod.pm @@ -0,0 +1,25 @@ +package Moose::Exception::CannotAugmentNoSuperMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "You cannot augment '".$self->method_name."' because it has no super method"; +} + +1; diff --git a/lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm b/lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm new file mode 100644 index 0000000..f0952bf --- /dev/null +++ b/lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotAutoDerefWithoutIsa; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "You cannot auto-dereference without specifying a type constraint on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm b/lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm new file mode 100644 index 0000000..3266ce4 --- /dev/null +++ b/lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotAutoDereferenceTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute', 'Moose::Exception::Role::Instance', 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + "Can not auto de-reference the type constraint '" . $self->type_name . "'"; +} + +1; diff --git a/lib/Moose/Exception/CannotCalculateNativeType.pm b/lib/Moose/Exception/CannotCalculateNativeType.pm new file mode 100644 index 0000000..2593cb4 --- /dev/null +++ b/lib/Moose/Exception/CannotCalculateNativeType.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotCalculateNativeType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +sub _build_message { + my $self = shift; + "Cannot calculate native type for " . ref $self->instance; +} + +1; diff --git a/lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm b/lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm new file mode 100644 index 0000000..3204c4e --- /dev/null +++ b/lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm @@ -0,0 +1,18 @@ +package Moose::Exception::CannotCallAnAbstractBaseMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'package_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + $self->package_name. " is an abstract base class, you must provide a constructor."; +} + +1; diff --git a/lib/Moose/Exception/CannotCallAnAbstractMethod.pm b/lib/Moose/Exception/CannotCallAnAbstractMethod.pm new file mode 100644 index 0000000..1d076ad --- /dev/null +++ b/lib/Moose/Exception/CannotCallAnAbstractMethod.pm @@ -0,0 +1,11 @@ +package Moose::Exception::CannotCallAnAbstractMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "Abstract method"; +} + +1; diff --git a/lib/Moose/Exception/CannotCoerceAWeakRef.pm b/lib/Moose/Exception/CannotCoerceAWeakRef.pm new file mode 100644 index 0000000..bb4a18b --- /dev/null +++ b/lib/Moose/Exception/CannotCoerceAWeakRef.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotCoerceAWeakRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "You cannot have a weak reference to a coerced value on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm b/lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm new file mode 100644 index 0000000..aabec96 --- /dev/null +++ b/lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm @@ -0,0 +1,16 @@ +package Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions', 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + my $name = $self->attribute_name; + my $type = $self->type_name; + + return "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"; +} + +1; diff --git a/lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm b/lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm new file mode 100644 index 0000000..fc7257b --- /dev/null +++ b/lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CannotCreateHigherOrderTypeWithoutATypeParameter; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + "You cannot create a Higher Order type without a type parameter"; +} + +1; diff --git a/lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm b/lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm new file mode 100644 index 0000000..fd3c85d --- /dev/null +++ b/lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm @@ -0,0 +1,24 @@ +package Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresent; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role', 'Moose::Exception::Role::Method'; + +has 'role_being_applied_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'aliased_method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "Cannot create a method alias if a local method of the same name exists"; +} + +1; diff --git a/lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm b/lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm new file mode 100644 index 0000000..df3d191 --- /dev/null +++ b/lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm @@ -0,0 +1,18 @@ +package Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresentInClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role', 'Moose::Exception::Role::Method', 'Moose::Exception::Role::Class'; + +has 'aliased_method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "Cannot create a method alias if a local method of the same name exists"; +} + +1; diff --git a/lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm b/lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm new file mode 100644 index 0000000..6232437 --- /dev/null +++ b/lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotDelegateLocalMethodIsPresent; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute', 'Moose::Exception::Role::Method'; + +sub _build_message { + my $self = shift; + "You cannot overwrite a locally defined method (".$self->method->name.") with a delegation"; +} + +1; diff --git a/lib/Moose/Exception/CannotDelegateWithoutIsa.pm b/lib/Moose/Exception/CannotDelegateWithoutIsa.pm new file mode 100644 index 0000000..e7ac308 --- /dev/null +++ b/lib/Moose/Exception/CannotDelegateWithoutIsa.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CannotDelegateWithoutIsa; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +sub _build_message { + "Cannot delegate methods based on a Regexp without a type constraint (isa)"; +} + +1; diff --git a/lib/Moose/Exception/CannotFindDelegateMetaclass.pm b/lib/Moose/Exception/CannotFindDelegateMetaclass.pm new file mode 100644 index 0000000..5cbb744 --- /dev/null +++ b/lib/Moose/Exception/CannotFindDelegateMetaclass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotFindDelegateMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +sub _build_message { + my $self = shift; + "Cannot find delegate metaclass for attribute ".$self->attribute->name; +} + +1; diff --git a/lib/Moose/Exception/CannotFindType.pm b/lib/Moose/Exception/CannotFindType.pm new file mode 100644 index 0000000..d9a3d89 --- /dev/null +++ b/lib/Moose/Exception/CannotFindType.pm @@ -0,0 +1,18 @@ +package Moose::Exception::CannotFindType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'type_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Cannot find type '".$self->type_name."', perhaps you forgot to load it"; +} + +1; diff --git a/lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm b/lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm new file mode 100644 index 0000000..147231f --- /dev/null +++ b/lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm @@ -0,0 +1,32 @@ +package Moose::Exception::CannotFindTypeGivenToMatchOnType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'to_match' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'action' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'type' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + my $type = $self->type; + + return "Cannot find or parse the type '$type'" +} + +1; diff --git a/lib/Moose/Exception/CannotFixMetaclassCompatibility.pm b/lib/Moose/Exception/CannotFixMetaclassCompatibility.pm new file mode 100644 index 0000000..8367213 --- /dev/null +++ b/lib/Moose/Exception/CannotFixMetaclassCompatibility.pm @@ -0,0 +1,25 @@ +package Moose::Exception::CannotFixMetaclassCompatibility; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'superclass' => ( + is => 'ro', + isa => 'Object', + required => 1 +); + +has 'metaclass_type' => ( + is => 'ro', + isa => 'Str', +); + +sub _build_message { + my $self = shift; + my $class_name = $self->class_name; + "Can't fix metaclass incompatibility for $class_name because it is not pristine."; +} + +1; diff --git a/lib/Moose/Exception/CannotGenerateInlineConstraint.pm b/lib/Moose/Exception/CannotGenerateInlineConstraint.pm new file mode 100644 index 0000000..55e5a1e --- /dev/null +++ b/lib/Moose/Exception/CannotGenerateInlineConstraint.pm @@ -0,0 +1,29 @@ +package Moose::Exception::CannotGenerateInlineConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +has 'parameterizable_type_object_name' => ( + is => 'ro', + isa => 'Str', + required => 1, + documentation => "This attribute can be used for fetching parameterizable type constraint(Moose::Meta::TypeConstraint::Parameterizable):\n". + " my \$type_constraint = Moose::Util::TypeConstraints::find_type_constraint( \$exception->type_name );\n", +); + +has 'value' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $type = $self->type_name; + + return "Can't generate an inline constraint for $type, since none was defined"; +} + +1; diff --git a/lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm b/lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm new file mode 100644 index 0000000..e1a0a4e --- /dev/null +++ b/lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm @@ -0,0 +1,29 @@ +package Moose::Exception::CannotInitializeMooseMetaRoleComposite; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'role_composite' => ( + is => 'ro', + isa => 'Moose::Meta::Role::Composite', + required => 1 +); + +has 'old_meta' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'args' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + 'Moose::Meta::Role::Composite instances can only be reinitialized from an existing metaclass instance'; +} + +1; diff --git a/lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm b/lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm new file mode 100644 index 0000000..2a99985 --- /dev/null +++ b/lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotInlineTypeConstraintCheck; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + 'Cannot inline a type constraint check for ' . $self->type_name; +} + +1; diff --git a/lib/Moose/Exception/CannotLocatePackageInINC.pm b/lib/Moose/Exception/CannotLocatePackageInINC.pm new file mode 100644 index 0000000..b910c16 --- /dev/null +++ b/lib/Moose/Exception/CannotLocatePackageInINC.pm @@ -0,0 +1,40 @@ +package Moose::Exception::CannotLocatePackageInINC; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'INC' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +has 'possible_packages' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'metaclass_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'type' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + my $possible_packages = $self->possible_packages; + my @inc = @{$self->INC}; + + return "Can't locate $possible_packages in \@INC (\@INC contains: @INC)." +} + +1; diff --git a/lib/Moose/Exception/CannotMakeMetaclassCompatible.pm b/lib/Moose/Exception/CannotMakeMetaclassCompatible.pm new file mode 100644 index 0000000..c313888 --- /dev/null +++ b/lib/Moose/Exception/CannotMakeMetaclassCompatible.pm @@ -0,0 +1,22 @@ +package Moose::Exception::CannotMakeMetaclassCompatible; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'superclass_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $class_name = $self->class_name; + my $superclass = $self->superclass_name; + + return "Can't make $class_name compatible with metaclass $superclass"; +} + +1; diff --git a/lib/Moose/Exception/CannotOverrideALocalMethod.pm b/lib/Moose/Exception/CannotOverrideALocalMethod.pm new file mode 100644 index 0000000..0730185 --- /dev/null +++ b/lib/Moose/Exception/CannotOverrideALocalMethod.pm @@ -0,0 +1,19 @@ +package Moose::Exception::CannotOverrideALocalMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "Cannot add an override of method '".$self->method_name."' because there is a local version of '".$self->method_name."'"; +} + +1; diff --git a/lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm b/lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm new file mode 100644 index 0000000..763779a --- /dev/null +++ b/lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm @@ -0,0 +1,18 @@ +package Moose::Exception::CannotOverrideBodyOfMetaMethods; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "Overriding the body of meta methods is not allowed"; +} + +1; diff --git a/lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm b/lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm new file mode 100644 index 0000000..42815c2 --- /dev/null +++ b/lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CannotOverrideLocalMethodIsPresent; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Method'; + +sub _build_message { + "Cannot add an override method if a local method is already present"; +} + +1; diff --git a/lib/Moose/Exception/CannotOverrideNoSuperMethod.pm b/lib/Moose/Exception/CannotOverrideNoSuperMethod.pm new file mode 100644 index 0000000..21fd873 --- /dev/null +++ b/lib/Moose/Exception/CannotOverrideNoSuperMethod.pm @@ -0,0 +1,25 @@ +package Moose::Exception::CannotOverrideNoSuperMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "You cannot override '".$self->method_name."' because it has no super method"; +} + +1; diff --git a/lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm b/lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm new file mode 100644 index 0000000..0182b1d --- /dev/null +++ b/lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm @@ -0,0 +1,11 @@ +package Moose::Exception::CannotRegisterUnnamedTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "can't register an unnamed type constraint"; +} + +1; diff --git a/lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm b/lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm new file mode 100644 index 0000000..36a2021 --- /dev/null +++ b/lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "You can not use lazy_build and default for the same attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/CircularReferenceInAlso.pm b/lib/Moose/Exception/CircularReferenceInAlso.pm new file mode 100644 index 0000000..7306adf --- /dev/null +++ b/lib/Moose/Exception/CircularReferenceInAlso.pm @@ -0,0 +1,30 @@ +package Moose::Exception::CircularReferenceInAlso; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'also_parameter' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'stack' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + my $self = shift; + my $also_member = $self->also_parameter; + + my @stack = @{$self->stack}; + my $existing_stack = join( ', ', @stack); + + return "Circular reference in 'also' parameter to Moose::Exporter between " + ."$existing_stack and $also_member"; +} + +1; diff --git a/lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm b/lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm new file mode 100644 index 0000000..a4c06bb --- /dev/null +++ b/lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm @@ -0,0 +1,21 @@ +package Moose::Exception::ClassDoesNotHaveInitMeta; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'traits' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + my $self = shift; + my $class = $self->class_name; + + return "Cannot provide traits when $class does not have an init_meta() method"; +} + +1; diff --git a/lib/Moose/Exception/ClassDoesTheExcludedRole.pm b/lib/Moose/Exception/ClassDoesTheExcludedRole.pm new file mode 100644 index 0000000..b53337f --- /dev/null +++ b/lib/Moose/Exception/ClassDoesTheExcludedRole.pm @@ -0,0 +1,21 @@ +package Moose::Exception::ClassDoesTheExcludedRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role', 'Moose::Exception::Role::Class'; + +has 'excluded_role_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $excluded_role_name = $self->excluded_role_name; + my $class_name = $self->class_name; + return "The class $class_name does the excluded role '$excluded_role_name'"; +} + +1; diff --git a/lib/Moose/Exception/ClassNamesDoNotMatch.pm b/lib/Moose/Exception/ClassNamesDoNotMatch.pm new file mode 100644 index 0000000..aca9dd8 --- /dev/null +++ b/lib/Moose/Exception/ClassNamesDoNotMatch.pm @@ -0,0 +1,24 @@ +package Moose::Exception::ClassNamesDoNotMatch; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has class_name => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +has class => ( + is => 'ro', + isa => 'Class::MOP::Class', + required => 1, +); + +sub _build_message { + my $self = shift; + "class_name (".$self-> class_name.") does not match class->name (".$self->class->name.")"; +} + +1; diff --git a/lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm b/lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm new file mode 100644 index 0000000..7ac0c8b --- /dev/null +++ b/lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm @@ -0,0 +1,19 @@ +package Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'instance' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + my $self = shift; + "You must pass an instance of the metaclass (" .$self->class_name. "), not (".$self->instance.")"; +} + +1; diff --git a/lib/Moose/Exception/CodeBlockMustBeACodeRef.pm b/lib/Moose/Exception/CodeBlockMustBeACodeRef.pm new file mode 100644 index 0000000..5b50a79 --- /dev/null +++ b/lib/Moose/Exception/CodeBlockMustBeACodeRef.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CodeBlockMustBeACodeRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash', 'Moose::Exception::Role::Instance'; + +sub _build_message { + "Your code block must be a CODE reference"; +} + +1; diff --git a/lib/Moose/Exception/CoercingWithoutCoercions.pm b/lib/Moose/Exception/CoercingWithoutCoercions.pm new file mode 100644 index 0000000..b2e3438 --- /dev/null +++ b/lib/Moose/Exception/CoercingWithoutCoercions.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CoercingWithoutCoercions; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + "Cannot coerce without a type coercion"; +} +1; diff --git a/lib/Moose/Exception/CoercionAlreadyExists.pm b/lib/Moose/Exception/CoercionAlreadyExists.pm new file mode 100644 index 0000000..53342d8 --- /dev/null +++ b/lib/Moose/Exception/CoercionAlreadyExists.pm @@ -0,0 +1,19 @@ +package Moose::Exception::CoercionAlreadyExists; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +has 'constraint_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "A coercion action already exists for '".$self->constraint_name."'"; +} + +1; diff --git a/lib/Moose/Exception/CoercionNeedsTypeConstraint.pm b/lib/Moose/Exception/CoercionNeedsTypeConstraint.pm new file mode 100644 index 0000000..b385be9 --- /dev/null +++ b/lib/Moose/Exception/CoercionNeedsTypeConstraint.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CoercionNeedsTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "You cannot have coercion without specifying a type constraint on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm b/lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm new file mode 100644 index 0000000..06f7de9 --- /dev/null +++ b/lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm @@ -0,0 +1,21 @@ +package Moose::Exception::ConflictDetectedInCheckRoleExclusions; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'excluded_role_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $role_name = $self->role_name; + my $excluded_role_name = $self->excluded_role_name; + return "Conflict detected: $role_name excludes role '$excluded_role_name'"; +} + +1; diff --git a/lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm b/lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm new file mode 100644 index 0000000..89b9baf --- /dev/null +++ b/lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm @@ -0,0 +1,15 @@ +package Moose::Exception::ConflictDetectedInCheckRoleExclusionsInToClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Role'; + +sub _build_message { + my $self = shift; + my $class_name = $self->class_name; + my $role_name = $self->role_name; + return "Conflict detected: $class_name excludes role '$role_name'"; +} + +1; diff --git a/lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm b/lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm new file mode 100644 index 0000000..3e0954a --- /dev/null +++ b/lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm @@ -0,0 +1,11 @@ +package Moose::Exception::ConstructClassInstanceTakesPackageName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "You must pass a package name"; +} + +1; diff --git a/lib/Moose/Exception/CouldNotCreateMethod.pm b/lib/Moose/Exception/CouldNotCreateMethod.pm new file mode 100644 index 0000000..e9497b7 --- /dev/null +++ b/lib/Moose/Exception/CouldNotCreateMethod.pm @@ -0,0 +1,31 @@ +package Moose::Exception::CouldNotCreateMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'option_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'option_value' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'error' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Could not create the '".$self->option_name."' method for " . $self->attribute->name . " because : ".$self->error; +} + +1; diff --git a/lib/Moose/Exception/CouldNotCreateWriter.pm b/lib/Moose/Exception/CouldNotCreateWriter.pm new file mode 100644 index 0000000..8bcb7fb --- /dev/null +++ b/lib/Moose/Exception/CouldNotCreateWriter.pm @@ -0,0 +1,23 @@ +package Moose::Exception::CouldNotCreateWriter; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::EitherAttributeOrAttributeName', 'Moose::Exception::Role::Instance'; + +has 'error' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $error = $self->error; + my $attribute_name = $self->attribute_name; + + return "Could not create writer for '$attribute_name' " + . "because $error"; +} + +1; diff --git a/lib/Moose/Exception/CouldNotEvalConstructor.pm b/lib/Moose/Exception/CouldNotEvalConstructor.pm new file mode 100644 index 0000000..95f5738 --- /dev/null +++ b/lib/Moose/Exception/CouldNotEvalConstructor.pm @@ -0,0 +1,33 @@ +package Moose::Exception::CouldNotEvalConstructor; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'constructor_method' => ( + is => 'ro', + isa => 'Class::MOP::Method::Constructor', + required => 1 +); + +has 'source' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'error' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $error = $self->error; + my $source = $self->source; + + return "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$error"; +} + +1; diff --git a/lib/Moose/Exception/CouldNotEvalDestructor.pm b/lib/Moose/Exception/CouldNotEvalDestructor.pm new file mode 100644 index 0000000..40ad749 --- /dev/null +++ b/lib/Moose/Exception/CouldNotEvalDestructor.pm @@ -0,0 +1,33 @@ +package Moose::Exception::CouldNotEvalDestructor; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'method_destructor_object' => ( + is => 'ro', + isa => 'Moose::Meta::Method::Destructor', + required => 1 +); + +has 'source' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'error' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $error = $self->error; + my $source = $self->source; + + return "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$error"; +} + +1; diff --git a/lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm b/lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm new file mode 100644 index 0000000..1e364b7 --- /dev/null +++ b/lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm @@ -0,0 +1,19 @@ +package Moose::Exception::CouldNotFindTypeConstraintToCoerceFrom; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +has 'constraint_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Could not find the type constraint (".$self->constraint_name.") to coerce from"; +} + +1; diff --git a/lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm b/lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm new file mode 100644 index 0000000..08ecc44 --- /dev/null +++ b/lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm @@ -0,0 +1,25 @@ +package Moose::Exception::CouldNotGenerateInlineAttributeMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +has 'option' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'error' => ( + is => 'ro', + isa => 'Str|Moose::Exception', + required => 1 +); + +sub _build_message { + my $self = shift; + "Could not generate inline ".$self->option." because : ".$self->error; +} + +1; diff --git a/lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm b/lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm new file mode 100644 index 0000000..7a52456 --- /dev/null +++ b/lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm @@ -0,0 +1,13 @@ +package Moose::Exception::CouldNotLocateTypeConstraintForUnion; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + "Could not locate type constraint (".$self->type_name.") for the union"; +} + +1; diff --git a/lib/Moose/Exception/CouldNotParseType.pm b/lib/Moose/Exception/CouldNotParseType.pm new file mode 100644 index 0000000..a87ecbc --- /dev/null +++ b/lib/Moose/Exception/CouldNotParseType.pm @@ -0,0 +1,29 @@ +package Moose::Exception::CouldNotParseType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'type' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'position' => ( + is => 'ro', + isa => 'Int', + required => 1 +); + +sub _build_message { + my $self = shift; + my $type = $self->type; + my $length = length($type); + my $position = $self->position; + + return "'$type' didn't parse (parse-pos=$position" + . " and str-length=$length)"; +} + +1; diff --git a/lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm b/lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm new file mode 100644 index 0000000..d266888 --- /dev/null +++ b/lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::RoleForCreateMOPClass'; + +sub _build_message { + "You must pass an ARRAY ref of attributes"; +} + +1; diff --git a/lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm b/lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm new file mode 100644 index 0000000..8a9f49a --- /dev/null +++ b/lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::RoleForCreateMOPClass'; + +sub _build_message { + "You must pass an ARRAY ref of superclasses"; +} + +1; diff --git a/lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm b/lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm new file mode 100644 index 0000000..9c17f4d --- /dev/null +++ b/lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CreateMOPClassTakesHashRefOfMethods; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::RoleForCreateMOPClass'; + +sub _build_message { + "You must pass an HASH ref of methods"; +} + +1; diff --git a/lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm b/lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm new file mode 100644 index 0000000..bd92403 --- /dev/null +++ b/lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CreateTakesArrayRefOfRoles; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::RoleForCreate'; + +sub _build_message { + "You must pass an ARRAY ref of roles"; +} + +1; diff --git a/lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm b/lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm new file mode 100644 index 0000000..d0b451c --- /dev/null +++ b/lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CreateTakesHashRefOfAttributes; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::RoleForCreate'; + +sub _build_message { + "You must pass a HASH ref of attributes"; +} + +1; diff --git a/lib/Moose/Exception/CreateTakesHashRefOfMethods.pm b/lib/Moose/Exception/CreateTakesHashRefOfMethods.pm new file mode 100644 index 0000000..6ef9000 --- /dev/null +++ b/lib/Moose/Exception/CreateTakesHashRefOfMethods.pm @@ -0,0 +1,12 @@ +package Moose::Exception::CreateTakesHashRefOfMethods; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::RoleForCreate'; + +sub _build_message { + "You must pass a HASH ref of methods"; +} + +1; diff --git a/lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm b/lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm new file mode 100644 index 0000000..74925ce --- /dev/null +++ b/lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm @@ -0,0 +1,32 @@ +package Moose::Exception::DefaultToMatchOnTypeMustBeCodeRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'to_match' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'default_action' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'cases_to_be_matched' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + my $self = shift; + my $default = $self->default_action; + + return "Default case must be a CODE ref, not $default"; +} + +1; diff --git a/lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm b/lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm new file mode 100644 index 0000000..6e96c80 --- /dev/null +++ b/lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm @@ -0,0 +1,19 @@ +package Moose::Exception::DelegationToAClassWhichIsNotLoaded; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'class_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "The ".$self->attribute->name." attribute is trying to delegate to a class which has not been loaded - ".$self->class_name; +} + +1; diff --git a/lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm b/lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm new file mode 100644 index 0000000..96a04ac --- /dev/null +++ b/lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm @@ -0,0 +1,19 @@ +package Moose::Exception::DelegationToARoleWhichIsNotLoaded; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'role_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "The ".$self->attribute->name." attribute is trying to delegate to a role which has not been loaded - ".$self->role_name; +} + +1; diff --git a/lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm b/lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm new file mode 100644 index 0000000..055c685 --- /dev/null +++ b/lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::DelegationToATypeWhichIsNotAClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +sub _build_message { + my $self = shift; + "The ".$self->attribute->name." attribute is trying to delegate to a type (".$self->attribute->type_constraint->name.") that is not backed by a class"; +} + +1; diff --git a/lib/Moose/Exception/DoesRequiresRoleName.pm b/lib/Moose/Exception/DoesRequiresRoleName.pm new file mode 100644 index 0000000..f3437ca --- /dev/null +++ b/lib/Moose/Exception/DoesRequiresRoleName.pm @@ -0,0 +1,12 @@ +package Moose::Exception::DoesRequiresRoleName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + "You must supply a role name to does()"; +} + +1; diff --git a/lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm b/lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm new file mode 100644 index 0000000..19fac8a --- /dev/null +++ b/lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm @@ -0,0 +1,23 @@ +package Moose::Exception::EnumCalledWithAnArrayRefAndAdditionalArgs; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'array' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +has 'args' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + "enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?"; +} + +1; diff --git a/lib/Moose/Exception/EnumValuesMustBeString.pm b/lib/Moose/Exception/EnumValuesMustBeString.pm new file mode 100644 index 0000000..6694e27 --- /dev/null +++ b/lib/Moose/Exception/EnumValuesMustBeString.pm @@ -0,0 +1,25 @@ +package Moose::Exception::EnumValuesMustBeString; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'value' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + "Enum values must be strings, not ".( defined $self->value ? "'".$self->value."'" : "undef" ); +} + +1; diff --git a/lib/Moose/Exception/ExtendsMissingArgs.pm b/lib/Moose/Exception/ExtendsMissingArgs.pm new file mode 100644 index 0000000..7c34923 --- /dev/null +++ b/lib/Moose/Exception/ExtendsMissingArgs.pm @@ -0,0 +1,12 @@ +package Moose::Exception::ExtendsMissingArgs; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + "Must derive at least one class"; +} + +1; diff --git a/lib/Moose/Exception/HandlesMustBeAHashRef.pm b/lib/Moose/Exception/HandlesMustBeAHashRef.pm new file mode 100644 index 0000000..9eb11a5 --- /dev/null +++ b/lib/Moose/Exception/HandlesMustBeAHashRef.pm @@ -0,0 +1,19 @@ +package Moose::Exception::HandlesMustBeAHashRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +has 'given_handles' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + "The 'handles' option must be a HASH reference, not ".$self->given_handles; +} + +1; diff --git a/lib/Moose/Exception/IllegalInheritedOptions.pm b/lib/Moose/Exception/IllegalInheritedOptions.pm new file mode 100644 index 0000000..2eae454 --- /dev/null +++ b/lib/Moose/Exception/IllegalInheritedOptions.pm @@ -0,0 +1,22 @@ +package Moose::Exception::IllegalInheritedOptions; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'illegal_options' => ( + is => 'ro', + traits => ['Array'], + handles => { + _join_options => 'join', + }, + required => 1, +); + +sub _build_message { + my $self = shift; + "Illegal inherited options => (".$self->_join_options(', ').")"; +} + +1; diff --git a/lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm b/lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm new file mode 100644 index 0000000..458a08b --- /dev/null +++ b/lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm @@ -0,0 +1,30 @@ +package Moose::Exception::IllegalMethodTypeToAddMethodModifier; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'class_or_object' => ( + is => 'ro', + isa => "Any", + required => 1, +); + +has 'params' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1, +); + +has 'modifier_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Methods passed to ".$self->modifier_name." must be provided as a list, arrayref or regex, not ".$self->params->[0]; +} + +1; diff --git a/lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm b/lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm new file mode 100644 index 0000000..98c8fb2 --- /dev/null +++ b/lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm @@ -0,0 +1,26 @@ +package Moose::Exception::IncompatibleMetaclassOfSuperclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has [qw/superclass_name superclass_meta_type class_meta_type/] => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + my $class_name = $self->class_name; + my $class_meta_type = $self->class_meta_type; + my $superclass_name = $self->superclass_name; + my $supermeta_type = $self->superclass_meta_type; + + return "The metaclass of $class_name ($class_meta_type)" . + " is not compatible with the metaclass of its superclass, " . + "$superclass_name ($supermeta_type)"; +} + +1; diff --git a/lib/Moose/Exception/InitMetaRequiresClass.pm b/lib/Moose/Exception/InitMetaRequiresClass.pm new file mode 100644 index 0000000..ca2fb06 --- /dev/null +++ b/lib/Moose/Exception/InitMetaRequiresClass.pm @@ -0,0 +1,12 @@ +package Moose::Exception::InitMetaRequiresClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +sub _build_message { + "Cannot call init_meta without specifying a for_class"; +} + +1; diff --git a/lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm b/lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm new file mode 100644 index 0000000..26f782f --- /dev/null +++ b/lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm @@ -0,0 +1,17 @@ +package Moose::Exception::InitializeTakesUnBlessedPackageName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'package_name' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + "You must pass a package name and it cannot be blessed"; +} + +1; diff --git a/lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm b/lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm new file mode 100644 index 0000000..4d4faff --- /dev/null +++ b/lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::InstanceBlessedIntoWrongClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash', 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Instance'; + +sub _build_message { + my $self = shift; + "Objects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but ".$self->instance." is not a " . $self->class_name; +} + +1; diff --git a/lib/Moose/Exception/InstanceMustBeABlessedReference.pm b/lib/Moose/Exception/InstanceMustBeABlessedReference.pm new file mode 100644 index 0000000..40b359d --- /dev/null +++ b/lib/Moose/Exception/InstanceMustBeABlessedReference.pm @@ -0,0 +1,19 @@ +package Moose::Exception::InstanceMustBeABlessedReference; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash', 'Moose::Exception::Role::Class'; + +has 'instance' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + "The __INSTANCE__ parameter must be a blessed reference, not ". $self->instance; +} + +1; diff --git a/lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm b/lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm new file mode 100644 index 0000000..2910e7a --- /dev/null +++ b/lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm @@ -0,0 +1,40 @@ +package Moose::Exception::InvalidArgPassedToMooseUtilMetaRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'argument' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + my $error = 'When using Moose::Util::MetaRole, you must pass a Moose class name,' + . ' role name, metaclass object, or metarole object.'; + + my $arg = $self->argument; + my $found = blessed $arg ? $arg : Class::MOP::class_of($arg); + + my $error2; + + if ( defined $found && blessed $found ) { + $error2 = " You passed ".$arg.", and we resolved this to a " + . ( blessed $found ) + . ' object.'; + } + elsif ( !defined $found ) { + $error2 = " You passed ".( defined $arg ? $arg : "undef" ).", and this did not resolve to a metaclass or metarole." + . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?'; + } + else { + $error2 = " You passed an undef." + . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?'; + } + + $error.$error2; +} + +1; diff --git a/lib/Moose/Exception/InvalidArgumentToMethod.pm b/lib/Moose/Exception/InvalidArgumentToMethod.pm new file mode 100644 index 0000000..df22ce7 --- /dev/null +++ b/lib/Moose/Exception/InvalidArgumentToMethod.pm @@ -0,0 +1,44 @@ +package Moose::Exception::InvalidArgumentToMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'argument' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has [qw(type type_of_argument method_name)] => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'ordinal' => ( + is => 'ro', + isa => 'Str', + predicate => 'is_ordinal_set' +); + +has 'argument_noun' => ( + is => 'ro', + isa => 'Str', + default => 'argument' +); + +sub _build_message { + my $self = shift; + my $article = ( $self->type_of_argument =~ /^[aeiou]/ ? 'an ' : 'a '); + my $arg_noun = $self->argument_noun; + + if( $self->is_ordinal_set ) { + "The ".$self->ordinal." $arg_noun passed to ".$self->method_name." must be ".$article.$self->type_of_argument; + } + else { + "The $arg_noun passed to ".$self->method_name." must be ".$article.$self->type_of_argument; + } +} + +1; diff --git a/lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm b/lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm new file mode 100644 index 0000000..c60af60 --- /dev/null +++ b/lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm @@ -0,0 +1,31 @@ +package Moose::Exception::InvalidArgumentsToTraitAliases; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +use Scalar::Util qw(reftype); + +has 'alias' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'package_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $alias = $self->alias; + my $reftype_alias = reftype($alias); + + return "$reftype_alias references are not " + . "valid arguments to the 'trait_aliases' option"; +} + +1; diff --git a/lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm b/lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm new file mode 100644 index 0000000..48a29c9 --- /dev/null +++ b/lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm @@ -0,0 +1,13 @@ +package Moose::Exception::InvalidBaseTypeGivenToCreateParameterizedTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + "Could not locate the base type (".$self->type_name.")"; +} + +1; diff --git a/lib/Moose/Exception/InvalidHandleValue.pm b/lib/Moose/Exception/InvalidHandleValue.pm new file mode 100644 index 0000000..04b7c8f --- /dev/null +++ b/lib/Moose/Exception/InvalidHandleValue.pm @@ -0,0 +1,19 @@ +package Moose::Exception::InvalidHandleValue; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +has 'handle_value' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + "All values passed to handles must be strings or ARRAY references, not ".$self->handle_value; +} + +1; diff --git a/lib/Moose/Exception/InvalidHasProvidedInARole.pm b/lib/Moose/Exception/InvalidHasProvidedInARole.pm new file mode 100644 index 0000000..d933d72 --- /dev/null +++ b/lib/Moose/Exception/InvalidHasProvidedInARole.pm @@ -0,0 +1,18 @@ +package Moose::Exception::InvalidHasProvidedInARole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + "Usage: has 'name' => ( key => value, ... )"; +} + +1; diff --git a/lib/Moose/Exception/InvalidNameForType.pm b/lib/Moose/Exception/InvalidNameForType.pm new file mode 100644 index 0000000..500eff2 --- /dev/null +++ b/lib/Moose/Exception/InvalidNameForType.pm @@ -0,0 +1,17 @@ +package Moose::Exception::InvalidNameForType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + $self->name." contains invalid characters for a type name. Names can contain alphanumeric character, ':', and '.'"; +} +1; diff --git a/lib/Moose/Exception/InvalidOverloadOperator.pm b/lib/Moose/Exception/InvalidOverloadOperator.pm new file mode 100644 index 0000000..2a04f12 --- /dev/null +++ b/lib/Moose/Exception/InvalidOverloadOperator.pm @@ -0,0 +1,20 @@ +package Moose::Exception::InvalidOverloadOperator; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has operator => ( + is => 'ro', + isa => 'Defined', + required => 1, +); + +sub _build_message { + my $self = shift; + 'The operator parameter you passed to the Moose::Meta::Overload constructor (' + . $self->operator() + . ') was not a valid overloading operator'; +} + +1; diff --git a/lib/Moose/Exception/InvalidRoleApplication.pm b/lib/Moose/Exception/InvalidRoleApplication.pm new file mode 100644 index 0000000..361cd61 --- /dev/null +++ b/lib/Moose/Exception/InvalidRoleApplication.pm @@ -0,0 +1,18 @@ +package Moose::Exception::InvalidRoleApplication; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'application' => ( + is => 'ro', + isa => "Any", + required => 1, +); + +sub _build_message { + "Role applications must be instances of Moose::Meta::Role::Application::ToClass"; +} + +1; diff --git a/lib/Moose/Exception/InvalidTypeConstraint.pm b/lib/Moose/Exception/InvalidTypeConstraint.pm new file mode 100644 index 0000000..4979400 --- /dev/null +++ b/lib/Moose/Exception/InvalidTypeConstraint.pm @@ -0,0 +1,23 @@ +package Moose::Exception::InvalidTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'registry_object' => ( + is => 'ro', + isa => 'Moose::Meta::TypeConstraint::Registry', + required => 1 +); + +has 'type' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + return "No type supplied / type is not a valid type constraint"; +} + +1; diff --git a/lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm b/lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm new file mode 100644 index 0000000..296e4ea --- /dev/null +++ b/lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm @@ -0,0 +1,13 @@ +package Moose::Exception::InvalidTypeGivenToCreateParameterizedTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + "Could not parse type name (".$self->type_name.") correctly"; +} + +1; diff --git a/lib/Moose/Exception/InvalidValueForIs.pm b/lib/Moose/Exception/InvalidValueForIs.pm new file mode 100644 index 0000000..a81e8fc --- /dev/null +++ b/lib/Moose/Exception/InvalidValueForIs.pm @@ -0,0 +1,13 @@ +package Moose::Exception::InvalidValueForIs; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "I do not understand this option (is => ".$self->params->{is}.") on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/IsaDoesNotDoTheRole.pm b/lib/Moose/Exception/IsaDoesNotDoTheRole.pm new file mode 100644 index 0000000..3abc897 --- /dev/null +++ b/lib/Moose/Exception/IsaDoesNotDoTheRole.pm @@ -0,0 +1,13 @@ +package Moose::Exception::IsaDoesNotDoTheRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "Cannot have an isa option and a does option if the isa does not do the does on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/IsaLacksDoesMethod.pm b/lib/Moose/Exception/IsaLacksDoesMethod.pm new file mode 100644 index 0000000..1ba2a85 --- /dev/null +++ b/lib/Moose/Exception/IsaLacksDoesMethod.pm @@ -0,0 +1,13 @@ +package Moose::Exception::IsaLacksDoesMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "Cannot have an isa option which cannot ->does() on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/LazyAttributeNeedsADefault.pm b/lib/Moose/Exception/LazyAttributeNeedsADefault.pm new file mode 100644 index 0000000..0ba36fa --- /dev/null +++ b/lib/Moose/Exception/LazyAttributeNeedsADefault.pm @@ -0,0 +1,13 @@ +package Moose::Exception::LazyAttributeNeedsADefault; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::EitherAttributeOrAttributeName'; + +sub _build_message { + my $self = shift; + "You cannot have a lazy attribute (".$self->attribute_name.") without specifying a default value for it"; +} + +1; diff --git a/lib/Moose/Exception/Legacy.pm b/lib/Moose/Exception/Legacy.pm new file mode 100644 index 0000000..d960f18 --- /dev/null +++ b/lib/Moose/Exception/Legacy.pm @@ -0,0 +1,7 @@ +package Moose::Exception::Legacy; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +1; diff --git a/lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm b/lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm new file mode 100644 index 0000000..3b62a92 --- /dev/null +++ b/lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MOPAttributeNewNeedsAttributeName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must provide a name for the attribute"; +} + +1; diff --git a/lib/Moose/Exception/MatchActionMustBeACodeRef.pm b/lib/Moose/Exception/MatchActionMustBeACodeRef.pm new file mode 100644 index 0000000..c0c7fb8 --- /dev/null +++ b/lib/Moose/Exception/MatchActionMustBeACodeRef.pm @@ -0,0 +1,27 @@ +package Moose::Exception::MatchActionMustBeACodeRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +has 'to_match' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +has 'action' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + my $action = $self->action; + + return "Match action must be a CODE ref, not $action"; +} + +1; diff --git a/lib/Moose/Exception/MessageParameterMustBeCodeRef.pm b/lib/Moose/Exception/MessageParameterMustBeCodeRef.pm new file mode 100644 index 0000000..c15f689 --- /dev/null +++ b/lib/Moose/Exception/MessageParameterMustBeCodeRef.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MessageParameterMustBeCodeRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "The 'message' parameter must be a coderef"; +} + +1; diff --git a/lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm b/lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm new file mode 100644 index 0000000..bbc90be --- /dev/null +++ b/lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm @@ -0,0 +1,23 @@ +package Moose::Exception::MetaclassIsAClassNotASubclassOfGivenMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +use Moose::Util 'find_meta'; + +has 'metaclass' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $class = find_meta( $self->class_name ); + $self->class_name." already has a metaclass, but it does not inherit ".$self->metaclass. + " ($class). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role."; +} + +1; diff --git a/lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm b/lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm new file mode 100644 index 0000000..b6dec64 --- /dev/null +++ b/lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm @@ -0,0 +1,25 @@ +package Moose::Exception::MetaclassIsARoleNotASubclassOfGivenMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +use Moose::Util 'find_meta'; + +has 'metaclass' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $role_name = $self->role_name; + my $role = find_meta( $role_name ); + my $metaclass = $self->metaclass; + return "$role_name already has a metaclass, but it does not inherit $metaclass ($role). " + ."You cannot make the same thing a role and a class. Remove either Moose or Moose::Role."; +} + +1; diff --git a/lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm b/lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm new file mode 100644 index 0000000..53f939b --- /dev/null +++ b/lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm @@ -0,0 +1,22 @@ +package Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +use Moose::Util 'find_meta'; + +has 'metaclass' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $class = find_meta( $self->class_name ); + $self->class_name." already has a metaclass, but it does not inherit ".$self->metaclass." ($class)."; +} + +1; diff --git a/lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm b/lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm new file mode 100644 index 0000000..6b22e2d --- /dev/null +++ b/lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::MetaclassMustBeASubclassOfMooseMetaClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + my $self = shift; + "The Metaclass ".$self->class_name." must be a subclass of Moose::Meta::Class." +} + +1; diff --git a/lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm b/lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm new file mode 100644 index 0000000..e638259 --- /dev/null +++ b/lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm @@ -0,0 +1,13 @@ +package Moose::Exception::MetaclassMustBeASubclassOfMooseMetaRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +sub _build_message { + my $self = shift; + "The Metaclass ".$self->role_name." must be a subclass of Moose::Meta::Role." +} + +1; diff --git a/lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm b/lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm new file mode 100644 index 0000000..f4d01f5 --- /dev/null +++ b/lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'class_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "The metaclass (".$self->class_name.") must be derived from Class::MOP::Class"; +} + +1; diff --git a/lib/Moose/Exception/MetaclassNotLoaded.pm b/lib/Moose/Exception/MetaclassNotLoaded.pm new file mode 100644 index 0000000..35238a9 --- /dev/null +++ b/lib/Moose/Exception/MetaclassNotLoaded.pm @@ -0,0 +1,13 @@ +package Moose::Exception::MetaclassNotLoaded; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + my $self = shift; + "The Metaclass ".$self->class_name." must be loaded. (Perhaps you forgot to 'use ".$self->class_name."'?)"; +} + +1; diff --git a/lib/Moose/Exception/MetaclassTypeIncompatible.pm b/lib/Moose/Exception/MetaclassTypeIncompatible.pm new file mode 100644 index 0000000..c56b5c3 --- /dev/null +++ b/lib/Moose/Exception/MetaclassTypeIncompatible.pm @@ -0,0 +1,38 @@ +package Moose::Exception::MetaclassTypeIncompatible; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +use Moose::Util 'find_meta'; + +has [qw(superclass_name metaclass_type)] => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $class_name = $self->class_name; + my $superclass_name = $self->superclass_name; + my $metaclass_type = $self->metaclass_type; + + my $metaclass_type_name = $metaclass_type; + $metaclass_type_name =~ s/_(?:meta)?class$//; + $metaclass_type_name =~ s/_/ /g; + + my $class = find_meta( $class_name ); + + my $self_metaclass_type = $class->$metaclass_type; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + my $super_metatype = $super_meta->$metaclass_type; + + return "The $metaclass_type metaclass for $class_name" + . " ($self_metaclass_type) is not compatible with the $metaclass_type_name" + . " metaclass of its superclass, $superclass_name ($super_metatype)"; +} + +1; diff --git a/lib/Moose/Exception/MethodExpectedAMetaclassObject.pm b/lib/Moose/Exception/MethodExpectedAMetaclassObject.pm new file mode 100644 index 0000000..7994cfc --- /dev/null +++ b/lib/Moose/Exception/MethodExpectedAMetaclassObject.pm @@ -0,0 +1,23 @@ +package Moose::Exception::MethodExpectedAMetaclassObject; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'metaclass' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "The is_needed method expected a metaclass object as its arugment"; +} + +1; diff --git a/lib/Moose/Exception/MethodExpectsFewerArgs.pm b/lib/Moose/Exception/MethodExpectsFewerArgs.pm new file mode 100644 index 0000000..e591a67 --- /dev/null +++ b/lib/Moose/Exception/MethodExpectsFewerArgs.pm @@ -0,0 +1,26 @@ +package Moose::Exception::MethodExpectsFewerArgs; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +has 'maximum_args' => ( + is => 'ro', + isa => 'Int', + required => 1, +); + +sub _build_message { + my $self = shift; + my $max = $self->maximum_args; + "Cannot call ".$self->method_name." with ". + ( $max ? "more than $max" : 'any'). " argument".( $max == 1 ? '' : 's' ); +} + +1; diff --git a/lib/Moose/Exception/MethodExpectsMoreArgs.pm b/lib/Moose/Exception/MethodExpectsMoreArgs.pm new file mode 100644 index 0000000..d0e82cf --- /dev/null +++ b/lib/Moose/Exception/MethodExpectsMoreArgs.pm @@ -0,0 +1,24 @@ +package Moose::Exception::MethodExpectsMoreArgs; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'minimum_args' => ( + is => 'ro', + isa => 'Int', + required => 1 +); + +sub _build_message { + my $self = shift; + "Cannot call ".$self->method_name." without at least ".$self->minimum_args." argument".($self->minimum_args == 1 ? '' : 's'); +} + +1; diff --git a/lib/Moose/Exception/MethodModifierNeedsMethodName.pm b/lib/Moose/Exception/MethodModifierNeedsMethodName.pm new file mode 100644 index 0000000..c940608 --- /dev/null +++ b/lib/Moose/Exception/MethodModifierNeedsMethodName.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MethodModifierNeedsMethodName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + "You must pass in a method name"; +} + +1; diff --git a/lib/Moose/Exception/MethodNameConflictInRoles.pm b/lib/Moose/Exception/MethodNameConflictInRoles.pm new file mode 100644 index 0000000..d6db656 --- /dev/null +++ b/lib/Moose/Exception/MethodNameConflictInRoles.pm @@ -0,0 +1,46 @@ +package Moose::Exception::MethodNameConflictInRoles; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'conflict' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Moose::Meta::Role::Method::Conflicting]', + handles => { conflict_methods_count => 'count', + get_method_at => 'get', + get_all_methods => 'elements', + }, + required => 1 +); + +sub _get_method_names { + my $self = shift; + + return ( $self->conflict_methods_count == 1 ? + "'".$self->get_method_at(0)->name."'": + Moose::Util::english_list( map { q{'} . $_->name . q{'} } $self->get_all_methods ) ); +} + +sub _build_message { + my $self = shift; + my $count = $self->conflict_methods_count; + my $roles = $self->get_method_at(0)->roles_as_english_list; + + if( $count == 1 ) + { + "Due to a method name conflict in roles " + .$roles.", the method ".$self->_get_method_names + ." must be implemented or excluded by '".$self->class_name."'"; + } + else + { + "Due to method name conflicts in roles " + .$roles.", the methods ".$self->_get_method_names + ." must be implemented or excluded by '".$self->class_name."'"; + } +} + +1; diff --git a/lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm b/lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm new file mode 100644 index 0000000..a724809 --- /dev/null +++ b/lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm @@ -0,0 +1,19 @@ +package Moose::Exception::MethodNameNotFoundInInheritanceHierarchy; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "The method '".$self->method_name."' was not found in the inheritance hierarchy for ".$self->class_name; +} + +1; diff --git a/lib/Moose/Exception/MethodNameNotGiven.pm b/lib/Moose/Exception/MethodNameNotGiven.pm new file mode 100644 index 0000000..e39ef0f --- /dev/null +++ b/lib/Moose/Exception/MethodNameNotGiven.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MethodNameNotGiven; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + "You must define a method name to find"; +} + +1; diff --git a/lib/Moose/Exception/MustDefineAMethodName.pm b/lib/Moose/Exception/MustDefineAMethodName.pm new file mode 100644 index 0000000..29d9114 --- /dev/null +++ b/lib/Moose/Exception/MustDefineAMethodName.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MustDefineAMethodName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +sub _build_message { + "You must define a method name"; +} + +1; diff --git a/lib/Moose/Exception/MustDefineAnAttributeName.pm b/lib/Moose/Exception/MustDefineAnAttributeName.pm new file mode 100644 index 0000000..2d818f7 --- /dev/null +++ b/lib/Moose/Exception/MustDefineAnAttributeName.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MustDefineAnAttributeName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + "You must define an attribute name"; +} + +1; diff --git a/lib/Moose/Exception/MustDefineAnOverloadOperator.pm b/lib/Moose/Exception/MustDefineAnOverloadOperator.pm new file mode 100644 index 0000000..e133c90 --- /dev/null +++ b/lib/Moose/Exception/MustDefineAnOverloadOperator.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MustDefineAnOverloadOperator; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Instance'; + +sub _build_message { + "You must define an overload operator"; +} + +1; diff --git a/lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm b/lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm new file mode 100644 index 0000000..0a9b599 --- /dev/null +++ b/lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustHaveAtLeastOneValueToEnumerate; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must have at least one value to enumerate through"; +} + +1; diff --git a/lib/Moose/Exception/MustPassAHashOfOptions.pm b/lib/Moose/Exception/MustPassAHashOfOptions.pm new file mode 100644 index 0000000..db4a305 --- /dev/null +++ b/lib/Moose/Exception/MustPassAHashOfOptions.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustPassAHashOfOptions; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must pass a hash of options"; +} + +1; diff --git a/lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm b/lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm new file mode 100644 index 0000000..b18fab0 --- /dev/null +++ b/lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm @@ -0,0 +1,23 @@ +package Moose::Exception::MustPassAMooseMetaRoleInstanceOrSubclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'role' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "You must pass a Moose::Meta::Role instance (or a subclass)"; +} + +1; diff --git a/lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm b/lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm new file mode 100644 index 0000000..7da9364 --- /dev/null +++ b/lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustPassAPackageNameOrAnExistingClassMOPPackageInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + "You must pass a package name or an existing Class::MOP::Package instance"; +} + +1; diff --git a/lib/Moose/Exception/MustPassEvenNumberOfArguments.pm b/lib/Moose/Exception/MustPassEvenNumberOfArguments.pm new file mode 100644 index 0000000..080645e --- /dev/null +++ b/lib/Moose/Exception/MustPassEvenNumberOfArguments.pm @@ -0,0 +1,24 @@ +package Moose::Exception::MustPassEvenNumberOfArguments; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'args' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "You must pass an even number of arguments to ".$self->method_name; +} + +1; diff --git a/lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm b/lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm new file mode 100644 index 0000000..090227b --- /dev/null +++ b/lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm @@ -0,0 +1,23 @@ +package Moose::Exception::MustPassEvenNumberOfAttributeOptions; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'options' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + return 'You must pass an even number of attribute options'; +} + +1; diff --git a/lib/Moose/Exception/MustProvideANameForTheAttribute.pm b/lib/Moose/Exception/MustProvideANameForTheAttribute.pm new file mode 100644 index 0000000..d5a48ff --- /dev/null +++ b/lib/Moose/Exception/MustProvideANameForTheAttribute.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustProvideANameForTheAttribute; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must provide a name for the attribute"; +} + +1; diff --git a/lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm b/lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm new file mode 100644 index 0000000..006a4e6 --- /dev/null +++ b/lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MustSpecifyAtleastOneMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +sub _build_message { + "Must specify at least one method"; +} + +1; diff --git a/lib/Moose/Exception/MustSpecifyAtleastOneRole.pm b/lib/Moose/Exception/MustSpecifyAtleastOneRole.pm new file mode 100644 index 0000000..dee07fc --- /dev/null +++ b/lib/Moose/Exception/MustSpecifyAtleastOneRole.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MustSpecifyAtleastOneRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +sub _build_message { + "Must specify at least one role"; +} + +1; diff --git a/lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm b/lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm new file mode 100644 index 0000000..38c5248 --- /dev/null +++ b/lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustSpecifyAtleastOneRoleToApplicant; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'applicant' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + my $self = shift; + "Must specify at least one role to apply to ".$self->applicant; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm b/lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm new file mode 100644 index 0000000..d34a93d --- /dev/null +++ b/lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustSupplyAClassMOPAttributeInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyADelegateToMethod.pm b/lib/Moose/Exception/MustSupplyADelegateToMethod.pm new file mode 100644 index 0000000..f86f8d2 --- /dev/null +++ b/lib/Moose/Exception/MustSupplyADelegateToMethod.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustSupplyADelegateToMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must supply a delegate_to_method which is a method name or a CODE reference"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyAMetaclass.pm b/lib/Moose/Exception/MustSupplyAMetaclass.pm new file mode 100644 index 0000000..fbb876a --- /dev/null +++ b/lib/Moose/Exception/MustSupplyAMetaclass.pm @@ -0,0 +1,19 @@ +package Moose::Exception::MustSupplyAMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "You must pass a metaclass instance if you want to inline"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm b/lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm new file mode 100644 index 0000000..83d1c72 --- /dev/null +++ b/lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustSupplyAMooseMetaAttributeInstance; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must supply an attribute which is a 'Moose::Meta::Attribute' instance"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm b/lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm new file mode 100644 index 0000000..29b09ff --- /dev/null +++ b/lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustSupplyAnAccessorTypeToConstructWith; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must supply an accessor_type to construct with"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm b/lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm new file mode 100644 index 0000000..c43b1a7 --- /dev/null +++ b/lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm @@ -0,0 +1,18 @@ +package Moose::Exception::MustSupplyAnAttributeToConstructWith; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must supply an attribute to construct with"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm b/lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm new file mode 100644 index 0000000..65fb9f9 --- /dev/null +++ b/lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm @@ -0,0 +1,12 @@ +package Moose::Exception::MustSupplyArrayRefAsCurriedArguments; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash', 'Moose::Exception::Role::Class'; + +sub _build_message { + "You must supply a curried_arguments which is an ARRAY reference"; +} + +1; diff --git a/lib/Moose/Exception/MustSupplyPackageNameAndName.pm b/lib/Moose/Exception/MustSupplyPackageNameAndName.pm new file mode 100644 index 0000000..3533397 --- /dev/null +++ b/lib/Moose/Exception/MustSupplyPackageNameAndName.pm @@ -0,0 +1,19 @@ +package Moose::Exception::MustSupplyPackageNameAndName; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "You must supply the package_name and name parameters"; +} + +1; diff --git a/lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm b/lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm new file mode 100644 index 0000000..c19b23d --- /dev/null +++ b/lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm @@ -0,0 +1,24 @@ +package Moose::Exception::NeedsTypeConstraintUnionForTypeCoercionUnion; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +# use Moose::Util::TypeConstraints 'find_type_constraint'; + +has 'type_coercion_union_object' => ( + is => 'ro', + isa => 'Moose::Meta::TypeCoercion::Union', + required => 1 +); + +sub _build_message { + my $self = shift; + my $type_constraint = $self->type_name; + + return "You can only create a Moose::Meta::TypeCoercion::Union for a " . + "Moose::Meta::TypeConstraint::Union, not a $type_constraint" +} + +1; diff --git a/lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm b/lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm new file mode 100644 index 0000000..c482bea --- /dev/null +++ b/lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm @@ -0,0 +1,11 @@ +package Moose::Exception::NeitherAttributeNorAttributeNameIsGiven; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "You need to give attribute or attribute_name or both"; +} + +1; diff --git a/lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm b/lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm new file mode 100644 index 0000000..e6c2a41 --- /dev/null +++ b/lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm @@ -0,0 +1,11 @@ +package Moose::Exception::NeitherClassNorClassNameIsGiven; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "You need to give class or class_name or both"; +} + +1; diff --git a/lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm b/lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm new file mode 100644 index 0000000..71cd416 --- /dev/null +++ b/lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm @@ -0,0 +1,11 @@ +package Moose::Exception::NeitherRoleNorRoleNameIsGiven; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "You need to give role or role_name or both"; +} + +1; diff --git a/lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm b/lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm new file mode 100644 index 0000000..115adc7 --- /dev/null +++ b/lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm @@ -0,0 +1,11 @@ +package Moose::Exception::NeitherTypeNorTypeNameIsGiven; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "You need to give type or type_name or both"; +} + +1; diff --git a/lib/Moose/Exception/NoAttributeFoundInSuperClass.pm b/lib/Moose/Exception/NoAttributeFoundInSuperClass.pm new file mode 100644 index 0000000..3cb66ed --- /dev/null +++ b/lib/Moose/Exception/NoAttributeFoundInSuperClass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::NoAttributeFoundInSuperClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "Could not find an attribute by the name of '".$self->attribute_name."' to inherit from in ".$self->class_name; +} + +1; diff --git a/lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm b/lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm new file mode 100644 index 0000000..55b88c9 --- /dev/null +++ b/lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm @@ -0,0 +1,18 @@ +package Moose::Exception::NoBodyToInitializeInAnAbstractBaseClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'package_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "No body to initialize, " .$self->package_name. " is an abstract base class"; +} + +1; diff --git a/lib/Moose/Exception/NoCasesMatched.pm b/lib/Moose/Exception/NoCasesMatched.pm new file mode 100644 index 0000000..33672a0 --- /dev/null +++ b/lib/Moose/Exception/NoCasesMatched.pm @@ -0,0 +1,26 @@ +package Moose::Exception::NoCasesMatched; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'to_match' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'cases_to_be_matched' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + my $self = shift; + my $to_match = $self->to_match; + + return "No cases matched for $to_match"; +} + +1; diff --git a/lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm b/lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm new file mode 100644 index 0000000..d50cc5c --- /dev/null +++ b/lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm @@ -0,0 +1,13 @@ +package Moose::Exception::NoConstraintCheckForTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + my $self = shift; + "Could not compile type constraint '".$self->type_name."' because no constraint check"; +} + +1; diff --git a/lib/Moose/Exception/NoDestructorClassSpecified.pm b/lib/Moose/Exception/NoDestructorClassSpecified.pm new file mode 100644 index 0000000..8d90d12 --- /dev/null +++ b/lib/Moose/Exception/NoDestructorClassSpecified.pm @@ -0,0 +1,12 @@ +package Moose::Exception::NoDestructorClassSpecified; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::ParamsHash'; + +sub _build_message { + "The 'inline_destructor' option is present, but no destructor class was specified"; +} + +1; diff --git a/lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm b/lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm new file mode 100644 index 0000000..2fe1c85 --- /dev/null +++ b/lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm @@ -0,0 +1,16 @@ +package Moose::Exception::NoImmutableTraitSpecifiedForClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::ParamsHash'; + +use Moose::Util 'find_meta'; + +sub _build_message { + my $self = shift; + my $class = find_meta( $self->class_name ); + "no immutable trait specified for $class"; +} + +1; diff --git a/lib/Moose/Exception/NoParentGivenToSubtype.pm b/lib/Moose/Exception/NoParentGivenToSubtype.pm new file mode 100644 index 0000000..799320b --- /dev/null +++ b/lib/Moose/Exception/NoParentGivenToSubtype.pm @@ -0,0 +1,17 @@ +package Moose::Exception::NoParentGivenToSubtype; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "A subtype cannot consist solely of a name, it must have a parent"; +} + +1; diff --git a/lib/Moose/Exception/OnlyInstancesCanBeCloned.pm b/lib/Moose/Exception/OnlyInstancesCanBeCloned.pm new file mode 100644 index 0000000..3f0b899 --- /dev/null +++ b/lib/Moose/Exception/OnlyInstancesCanBeCloned.pm @@ -0,0 +1,19 @@ +package Moose::Exception::OnlyInstancesCanBeCloned; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::ParamsHash'; + +has 'instance' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + my $self = shift; + "You can only clone instances, (".$self->instance.") is not a blessed instance"; +} + +1; diff --git a/lib/Moose/Exception/OperatorIsRequired.pm b/lib/Moose/Exception/OperatorIsRequired.pm new file mode 100644 index 0000000..d14a846 --- /dev/null +++ b/lib/Moose/Exception/OperatorIsRequired.pm @@ -0,0 +1,18 @@ +package Moose::Exception::OperatorIsRequired; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "operator is required"; +} + +1; diff --git a/lib/Moose/Exception/OverloadConflictInSummation.pm b/lib/Moose/Exception/OverloadConflictInSummation.pm new file mode 100644 index 0000000..0292326 --- /dev/null +++ b/lib/Moose/Exception/OverloadConflictInSummation.pm @@ -0,0 +1,61 @@ +package Moose::Exception::OverloadConflictInSummation; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +use Moose::Util 'find_meta'; + +has 'role_application' => ( + is => 'ro', + isa => 'Moose::Meta::Role::Application::RoleSummation', + required => 1 +); + +has 'role_names' => ( + traits => ['Array'], + is => 'bare', + isa => 'ArrayRef[Str]', + handles => { + role_names => 'elements', + }, + required => 1, + documentation => + "This attribute is an ArrayRef containing role names, if you want metaobjects\n" + . "associated with these role names, then call method roles on the exception object.\n", +); + +has 'overloaded_op' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub roles { + my $self = shift; + my @role_names = $self->role_names; + my @roles = map { find_meta($_) } @role_names; + return @roles; +} + +sub _build_message { + my $self = shift; + + my @roles = $self->role_names; + my $role_names = join "|", @roles; + + my $op = $self->overloaded_op; + if ( $op eq 'fallback' ) { + return + 'We have encountered an overloading conflict for the fallback ' + . 'during composition. This is a fatal error.'; + } + else { + return + "Role '$role_names' has encountered an overloading conflict " + . "during composition. The two roles both overload the '$op' operator. " + . 'This is a fatal error.'; + } +} + +1; diff --git a/lib/Moose/Exception/OverloadRequiresAMetaClass.pm b/lib/Moose/Exception/OverloadRequiresAMetaClass.pm new file mode 100644 index 0000000..1f41861 --- /dev/null +++ b/lib/Moose/Exception/OverloadRequiresAMetaClass.pm @@ -0,0 +1,12 @@ +package Moose::Exception::OverloadRequiresAMetaClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + my $self = shift; + 'If you provide an associated_metaclass parameter to the Moose::Meta::Overload constructor it must be a Class::MOP::Module object'; +} + +1; diff --git a/lib/Moose/Exception/OverloadRequiresAMetaMethod.pm b/lib/Moose/Exception/OverloadRequiresAMetaMethod.pm new file mode 100644 index 0000000..67ee8ee --- /dev/null +++ b/lib/Moose/Exception/OverloadRequiresAMetaMethod.pm @@ -0,0 +1,12 @@ +package Moose::Exception::OverloadRequiresAMetaMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + my $self = shift; + 'If you provide a method parameter to the Moose::Meta::Overload constructor it must be a Class::MOP::Method object'; +} + +1; diff --git a/lib/Moose/Exception/OverloadRequiresAMetaOverload.pm b/lib/Moose/Exception/OverloadRequiresAMetaOverload.pm new file mode 100644 index 0000000..5545d74 --- /dev/null +++ b/lib/Moose/Exception/OverloadRequiresAMetaOverload.pm @@ -0,0 +1,12 @@ +package Moose::Exception::OverloadRequiresAMetaOverload; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + my $self = shift; + 'If you provide an original_overload parameter to the Moose::Meta::Overload constructor it must be a Moose::Meta::Overload object'; +} + +1; diff --git a/lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm b/lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm new file mode 100644 index 0000000..dd8c1f9 --- /dev/null +++ b/lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm @@ -0,0 +1,12 @@ +package Moose::Exception::OverloadRequiresAMethodNameOrCoderef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + my $self = shift; + 'You must provide a method_name or coderef parameter when constructing a Moose::Meta::Overload object'; +} + +1; diff --git a/lib/Moose/Exception/OverloadRequiresAnOperator.pm b/lib/Moose/Exception/OverloadRequiresAnOperator.pm new file mode 100644 index 0000000..7952920 --- /dev/null +++ b/lib/Moose/Exception/OverloadRequiresAnOperator.pm @@ -0,0 +1,12 @@ +package Moose::Exception::OverloadRequiresAnOperator; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + my $self = shift; + 'You must provide an operator parameter when constructing a Moose::Meta::Overload object'; +} + +1; diff --git a/lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm b/lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm new file mode 100644 index 0000000..82401d0 --- /dev/null +++ b/lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm @@ -0,0 +1,12 @@ +package Moose::Exception::OverloadRequiresNamesForCoderef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + my $self = shift; + 'If you provide a coderef parameter to the Moose::Meta::Overload constructor you must also provide coderef_package and coderef_name parameters'; +} + +1; diff --git a/lib/Moose/Exception/OverrideConflictInComposition.pm b/lib/Moose/Exception/OverrideConflictInComposition.pm new file mode 100644 index 0000000..44bfd78 --- /dev/null +++ b/lib/Moose/Exception/OverrideConflictInComposition.pm @@ -0,0 +1,42 @@ +package Moose::Exception::OverrideConflictInComposition; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'role_being_applied_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'two_overrides_found' => ( + is => 'ro', + isa => 'Bool', + required => 1, + default => 0 +); + +sub _build_message { + my $self = shift; + + if( $self->two_overrides_found ) { + return "Role '" . $self->role_being_applied_name . "' has encountered an 'override' method conflict " . + "during composition (Two 'override' methods of the same name encountered). " . + "This is a fatal error."; + } + else { + return "Role '".$self->role_being_applied_name."' has encountered an 'override' method conflict ". + "during composition (A local method of the same name as been found). ". + "This is a fatal error."; + } +} + +1; diff --git a/lib/Moose/Exception/OverrideConflictInSummation.pm b/lib/Moose/Exception/OverrideConflictInSummation.pm new file mode 100644 index 0000000..e88d9cc --- /dev/null +++ b/lib/Moose/Exception/OverrideConflictInSummation.pm @@ -0,0 +1,65 @@ +package Moose::Exception::OverrideConflictInSummation; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +use Moose::Util 'find_meta'; + +has 'role_application' => ( + is => 'ro', + isa => 'Moose::Meta::Role::Application::RoleSummation', + required => 1 +); + +has 'role_names' => ( + traits => ['Array'], + is => 'bare', + isa => 'ArrayRef[Str]', + handles => { + role_names => 'elements', + }, + required => 1, + documentation => "This attribute is an ArrayRef containing role names, if you want metaobjects\n". + "associated with these role names, then call method roles on the exception object.\n", +); + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'two_overrides_found' => ( + is => 'ro', + isa => 'Bool', + required => 1, + default => 0 +); + +sub roles { + my $self = shift; + my @role_names = $self->role_names; + my @roles = map { find_meta($_) } @role_names; + return @roles; +} + +sub _build_message { + my $self = shift; + + my @roles = $self->role_names; + my $role_names = join "|", @roles; + + if( $self->two_overrides_found ) { + return "We have encountered an 'override' method conflict ". + "during composition (Two 'override' methods of the same name encountered). ". + "This is a fatal error."; + } + else { + return "Role '$role_names' has encountered an 'override' method conflict " . + "during composition (A local method of the same name has been found). This " . + "is a fatal error." ; + } +} + +1; diff --git a/lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm b/lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm new file mode 100644 index 0000000..acd8ea6 --- /dev/null +++ b/lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm @@ -0,0 +1,27 @@ +package Moose::Exception::PackageDoesNotUseMooseExporter; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'package' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'is_loaded' => ( + is => 'ro', + isa => 'Bool', + required => 1 +); + +sub _build_message { + my $self = shift; + my $package = $self->package; + return "Package in also ($package) does not seem to " + . "use Moose::Exporter" + . ( $self->is_loaded ? "" : " (is it loaded?)" ); +} + +1; diff --git a/lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm b/lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm new file mode 100644 index 0000000..efdb7ef --- /dev/null +++ b/lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm @@ -0,0 +1,24 @@ +package Moose::Exception::PackageNameAndNameParamsNotGivenToWrap; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'code' => ( + is => 'ro', + isa => 'CodeRef', + required => 1 +); + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "You must supply the package_name and name parameters"; +} + +1; diff --git a/lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm b/lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm new file mode 100644 index 0000000..901f635 --- /dev/null +++ b/lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm @@ -0,0 +1,25 @@ +package Moose::Exception::PackagesAndModulesAreNotCachable; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::ParamsHash'; + +has 'is_module' => ( + is => 'ro', + isa => 'Bool', + required => 1 +); + +sub _build_message { + my $self = shift; + my $is_module = $self->is_module; + + if( $is_module ) { + return "Modules are not cacheable"; + } else { + return "Packages are not cacheable"; + } +} + +1; diff --git a/lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm b/lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm new file mode 100644 index 0000000..edc7280 --- /dev/null +++ b/lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm @@ -0,0 +1,25 @@ +package Moose::Exception::ParameterIsNotSubtypeOfParent; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +use Moose::Util::TypeConstraints qw/find_type_constraint/; + +has 'type_parameter' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $type_parameter = $self->type_parameter; + my $type = find_type_constraint( $self->type_name ); + my $parent = $type->parent->type_parameter; + + return "$type_parameter is not a subtype of $parent"; +} + +1; diff --git a/lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm b/lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm new file mode 100644 index 0000000..1a460c1 --- /dev/null +++ b/lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm @@ -0,0 +1,26 @@ +package Moose::Exception::ReferencesAreNotAllowedAsDefault; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "References are not allowed as default values, you must wrap the default of '". + $self->attribute_name."' in a CODE reference (ex: sub { [] } and not [])"; +} + +1; diff --git a/lib/Moose/Exception/RequiredAttributeLacksInitialization.pm b/lib/Moose/Exception/RequiredAttributeLacksInitialization.pm new file mode 100644 index 0000000..9282048 --- /dev/null +++ b/lib/Moose/Exception/RequiredAttributeLacksInitialization.pm @@ -0,0 +1,18 @@ +package Moose::Exception::RequiredAttributeLacksInitialization; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + "A required attribute must have either 'init_arg', 'builder', or 'default'"; +} + +1; diff --git a/lib/Moose/Exception/RequiredAttributeNeedsADefault.pm b/lib/Moose/Exception/RequiredAttributeNeedsADefault.pm new file mode 100644 index 0000000..d823852 --- /dev/null +++ b/lib/Moose/Exception/RequiredAttributeNeedsADefault.pm @@ -0,0 +1,13 @@ +package Moose::Exception::RequiredAttributeNeedsADefault; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "You cannot have a required attribute (".$self->attribute_name.") without a default, builder, or an init_arg"; +} + +1; diff --git a/lib/Moose/Exception/RequiredMethodsImportedByClass.pm b/lib/Moose/Exception/RequiredMethodsImportedByClass.pm new file mode 100644 index 0000000..262883e --- /dev/null +++ b/lib/Moose/Exception/RequiredMethodsImportedByClass.pm @@ -0,0 +1,45 @@ +package Moose::Exception::RequiredMethodsImportedByClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Role'; + +has 'missing_methods' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Moose::Meta::Role::Method::Required]', + handles => { method_count => 'count', + get_method_at => 'get', + get_all_methods => 'elements', + }, + required => 1 +); + +has 'imported_method' => ( + is => 'ro', + isa => 'Moose::Meta::Role::Method::Required', + required => 1 +); + +sub _build_message { + my $self = shift; + + my $noun = $self->method_count == 1 ? 'method' : 'methods'; + my $list = Moose::Util::english_list( map { q{'} . $_ . q{'} } $self->get_all_methods ); + + my ($class, $role, $method) = ($self->class_name, + $self->role_name, + $self->imported_method); + + my ($class_quoted, $role_quoted) = ("'".$class."'","'".$role."'"); + + "$role_quoted requires the $noun $list " + . "to be implemented by $class_quoted. " + . "If you imported functions intending to use them as " + . "methods, you need to explicitly mark them as such, via " + . "$class->meta->add_method($method" + . " => \\&$method)"; +} + +1; diff --git a/lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm b/lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm new file mode 100644 index 0000000..541c169 --- /dev/null +++ b/lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm @@ -0,0 +1,30 @@ +package Moose::Exception::RequiredMethodsNotImplementedByClass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class', 'Moose::Exception::Role::Role'; + +has 'missing_methods' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Moose::Meta::Role::Method::Required]', + handles => { method_count => 'count', + get_method_at => 'get', + get_all_methods => 'elements', + }, + required => 1 +); + +sub _build_message { + my $self = shift; + + my $noun = $self->method_count == 1 ? 'method' : 'methods'; + my $list = Moose::Util::english_list( map { q{'} . $_ . q{'} } $self->get_all_methods ); + my ($role_name, $class_name) = ($self->role_name, $self->class_name); + + return "'$role_name' requires the $noun $list " + . "to be implemented by '$class_name'"; +} + +1; diff --git a/lib/Moose/Exception/Role/Attribute.pm b/lib/Moose/Exception/Role/Attribute.pm new file mode 100644 index 0000000..02d0c5d --- /dev/null +++ b/lib/Moose/Exception/Role/Attribute.pm @@ -0,0 +1,12 @@ +package Moose::Exception::Role::Attribute; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'attribute' => ( + is => 'ro', + isa => 'Class::MOP::Attribute', + predicate => 'is_attribute_set' +); + +1; diff --git a/lib/Moose/Exception/Role/AttributeName.pm b/lib/Moose/Exception/Role/AttributeName.pm new file mode 100644 index 0000000..b00f41e --- /dev/null +++ b/lib/Moose/Exception/Role/AttributeName.pm @@ -0,0 +1,12 @@ +package Moose::Exception::Role::AttributeName; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +1; diff --git a/lib/Moose/Exception/Role/Class.pm b/lib/Moose/Exception/Role/Class.pm new file mode 100644 index 0000000..c523997 --- /dev/null +++ b/lib/Moose/Exception/Role/Class.pm @@ -0,0 +1,14 @@ +package Moose::Exception::Role::Class; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'class_name' => ( + is => 'ro', + isa => 'Str', + required => 1, + documentation => "This attribute can be used for fetching metaclass instance:\n". + " my \$metaclass_instance = Moose::Util::find_meta( \$exception->class_name );\n", +); + +1; diff --git a/lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm b/lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm new file mode 100644 index 0000000..5b76867 --- /dev/null +++ b/lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm @@ -0,0 +1,49 @@ +package Moose::Exception::Role::EitherAttributeOrAttributeName; +our $VERSION = '2.1405'; + +use Moose::Util 'throw_exception'; +use Moose::Role; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + lazy_build => 1 +); + +has 'attribute' => ( + is => 'ro', + isa => 'Class::MOP::Attribute', + predicate => 'has_attribute' +); + +has 'params' => ( + is => 'ro', + isa => 'HashRef', + predicate => 'has_params', +); + +sub _build_attribute_name { + my $self = shift; + + if( !$self->has_attribute ) + { + throw_exception("NeitherAttributeNorAttributeNameIsGiven"); + } + + return $self->attribute->name; +} + +after "BUILD" => sub { + my $self = $_[0]; + + if( $self->has_attribute_name && + $self->has_attribute && + ( $self->attribute->name ne $self->attribute_name ) ) + { + throw_exception( AttributeNamesDoNotMatch => attribute_name => $self->attribute_name, + attribute => $self->attribute + ); + } +}; + +1; diff --git a/lib/Moose/Exception/Role/Instance.pm b/lib/Moose/Exception/Role/Instance.pm new file mode 100644 index 0000000..e3c094e --- /dev/null +++ b/lib/Moose/Exception/Role/Instance.pm @@ -0,0 +1,12 @@ +package Moose::Exception::Role::Instance; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'instance' => ( + is => 'ro', + isa => 'Object', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/InstanceClass.pm b/lib/Moose/Exception/Role/InstanceClass.pm new file mode 100644 index 0000000..e74a33f --- /dev/null +++ b/lib/Moose/Exception/Role/InstanceClass.pm @@ -0,0 +1,12 @@ +package Moose::Exception::Role::InstanceClass; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'instance_class' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/InvalidAttributeOptions.pm b/lib/Moose/Exception/Role/InvalidAttributeOptions.pm new file mode 100644 index 0000000..9a754ac --- /dev/null +++ b/lib/Moose/Exception/Role/InvalidAttributeOptions.pm @@ -0,0 +1,13 @@ +package Moose::Exception::Role::InvalidAttributeOptions; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Exception::Role::ParamsHash'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/Method.pm b/lib/Moose/Exception/Role/Method.pm new file mode 100644 index 0000000..b2a1f4b --- /dev/null +++ b/lib/Moose/Exception/Role/Method.pm @@ -0,0 +1,12 @@ +package Moose::Exception::Role::Method; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'method' => ( + is => 'ro', + isa => 'Moose::Meta::Method', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/ParamsHash.pm b/lib/Moose/Exception/Role/ParamsHash.pm new file mode 100644 index 0000000..02b6bf9 --- /dev/null +++ b/lib/Moose/Exception/Role/ParamsHash.pm @@ -0,0 +1,12 @@ +package Moose::Exception::Role::ParamsHash; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'params' => ( + is => 'ro', + isa => 'HashRef', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/Role.pm b/lib/Moose/Exception/Role/Role.pm new file mode 100644 index 0000000..c787234 --- /dev/null +++ b/lib/Moose/Exception/Role/Role.pm @@ -0,0 +1,16 @@ +package Moose::Exception::Role::Role; +our $VERSION = '2.1405'; + +# use Moose::Util 'throw_exception'; +use Moose::Role; + +has 'role_name' => ( + is => 'ro', + isa => 'Str', + required => 1, + documentation => "This attribute can be used for fetching metaclass instance:\n". + " my \$metaclass_instance = Moose::Util::find_meta( \$exception->role_name );\n", + +); + +1; diff --git a/lib/Moose/Exception/Role/RoleForCreate.pm b/lib/Moose/Exception/Role/RoleForCreate.pm new file mode 100644 index 0000000..23e6b12 --- /dev/null +++ b/lib/Moose/Exception/Role/RoleForCreate.pm @@ -0,0 +1,13 @@ +package Moose::Exception::Role::RoleForCreate; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Exception::Role::ParamsHash'; + +has 'attribute_class' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/RoleForCreateMOPClass.pm b/lib/Moose/Exception/Role/RoleForCreateMOPClass.pm new file mode 100644 index 0000000..a9a07c0 --- /dev/null +++ b/lib/Moose/Exception/Role/RoleForCreateMOPClass.pm @@ -0,0 +1,13 @@ +package Moose::Exception::Role::RoleForCreateMOPClass; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +1; diff --git a/lib/Moose/Exception/Role/TypeConstraint.pm b/lib/Moose/Exception/Role/TypeConstraint.pm new file mode 100644 index 0000000..cd73986 --- /dev/null +++ b/lib/Moose/Exception/Role/TypeConstraint.pm @@ -0,0 +1,14 @@ +package Moose::Exception::Role::TypeConstraint; +our $VERSION = '2.1405'; + +use Moose::Role; + +has 'type_name' => ( + is => 'ro', + isa => 'Str', + required => 1, + documentation => "This attribute can be used for fetching type constraint(Moose::Meta::TypeConstraint):\n". + " my \$type_constraint = Moose::Util::TypeConstraints::find_type_constraint( \$exception->type_name );\n", +); + +1; diff --git a/lib/Moose/Exception/RoleDoesTheExcludedRole.pm b/lib/Moose/Exception/RoleDoesTheExcludedRole.pm new file mode 100644 index 0000000..e0f5d3a --- /dev/null +++ b/lib/Moose/Exception/RoleDoesTheExcludedRole.pm @@ -0,0 +1,27 @@ +package Moose::Exception::RoleDoesTheExcludedRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'excluded_role_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'second_role_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + my $role_name = $self->role_name; + my $excluded_role_name = $self->excluded_role_name; + return "The role $role_name does the excluded role '$excluded_role_name'"; +} + +1; diff --git a/lib/Moose/Exception/RoleExclusionConflict.pm b/lib/Moose/Exception/RoleExclusionConflict.pm new file mode 100644 index 0000000..210ec90 --- /dev/null +++ b/lib/Moose/Exception/RoleExclusionConflict.pm @@ -0,0 +1,26 @@ +package Moose::Exception::RoleExclusionConflict; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'roles' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1, +); + +sub _build_message { + my $self = shift; + + my @roles_array = @{$self->roles}; + my $role_noun = "Role".( @roles_array == 1 ? '' : 's'); + my $all_roles = join(', ', @roles_array); + my $verb = "exclude".( @roles_array == 1 ? 's' : '' ); + my $role_name = $self->role_name; + + return "Conflict detected: $role_noun $all_roles $verb role '$role_name'"; +} + +1; diff --git a/lib/Moose/Exception/RoleNameRequired.pm b/lib/Moose/Exception/RoleNameRequired.pm new file mode 100644 index 0000000..7a90e04 --- /dev/null +++ b/lib/Moose/Exception/RoleNameRequired.pm @@ -0,0 +1,12 @@ +package Moose::Exception::RoleNameRequired; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +sub _build_message { + "You must supply a role name to look for"; +} + +1; diff --git a/lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm b/lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm new file mode 100644 index 0000000..54f1340 --- /dev/null +++ b/lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm @@ -0,0 +1,12 @@ +package Moose::Exception::RoleNameRequiredForMooseMetaRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +sub _build_message { + "You must supply a role name to look for"; +} + +1; diff --git a/lib/Moose/Exception/RolesDoNotSupportAugment.pm b/lib/Moose/Exception/RolesDoNotSupportAugment.pm new file mode 100644 index 0000000..91f366c --- /dev/null +++ b/lib/Moose/Exception/RolesDoNotSupportAugment.pm @@ -0,0 +1,11 @@ +package Moose::Exception::RolesDoNotSupportAugment; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "Roles cannot support 'augment'"; +} + +1; diff --git a/lib/Moose/Exception/RolesDoNotSupportExtends.pm b/lib/Moose/Exception/RolesDoNotSupportExtends.pm new file mode 100644 index 0000000..a18ceac --- /dev/null +++ b/lib/Moose/Exception/RolesDoNotSupportExtends.pm @@ -0,0 +1,11 @@ +package Moose::Exception::RolesDoNotSupportExtends; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "Roles do not support 'extends' (you can use 'with' to specialize a role)"; +} + +1; diff --git a/lib/Moose/Exception/RolesDoNotSupportInner.pm b/lib/Moose/Exception/RolesDoNotSupportInner.pm new file mode 100644 index 0000000..d075ae4 --- /dev/null +++ b/lib/Moose/Exception/RolesDoNotSupportInner.pm @@ -0,0 +1,11 @@ +package Moose::Exception::RolesDoNotSupportInner; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "Roles cannot support 'inner'"; +} + +1; diff --git a/lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm b/lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm new file mode 100644 index 0000000..89e5046 --- /dev/null +++ b/lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm @@ -0,0 +1,19 @@ +package Moose::Exception::RolesDoNotSupportRegexReferencesForMethodModifiers; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Role'; + +has 'modifier_type' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Roles do not currently support regex references for ".$self->modifier_type." method modifiers"; +} + +1; diff --git a/lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm b/lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm new file mode 100644 index 0000000..70ca26c --- /dev/null +++ b/lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm @@ -0,0 +1,13 @@ +package Moose::Exception::RolesInCreateTakesAnArrayRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +sub _build_message { + my $self = shift; + "You must pass an ARRAY ref of roles"; +} + +1; diff --git a/lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm b/lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm new file mode 100644 index 0000000..d06354a --- /dev/null +++ b/lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm @@ -0,0 +1,25 @@ +package Moose::Exception::RolesListMustBeInstancesOfMooseMetaRole; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'role' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + "The list of roles must be instances of Moose::Meta::Role, not ".$self->role; +} + +1; diff --git a/lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm b/lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm new file mode 100644 index 0000000..d61073c --- /dev/null +++ b/lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm @@ -0,0 +1,11 @@ +package Moose::Exception::SingleParamsToNewMustBeHashRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "Single parameters to new() must be a HASH ref"; +} + +1; diff --git a/lib/Moose/Exception/TriggerMustBeACodeRef.pm b/lib/Moose/Exception/TriggerMustBeACodeRef.pm new file mode 100644 index 0000000..3af0d3f --- /dev/null +++ b/lib/Moose/Exception/TriggerMustBeACodeRef.pm @@ -0,0 +1,13 @@ +package Moose::Exception::TriggerMustBeACodeRef; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::InvalidAttributeOptions'; + +sub _build_message { + my $self = shift; + "Trigger must be a CODE ref on attribute (".$self->attribute_name.")"; +} + +1; diff --git a/lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm b/lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm new file mode 100644 index 0000000..337a7df --- /dev/null +++ b/lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm @@ -0,0 +1,24 @@ +package Moose::Exception::TypeConstraintCannotBeUsedForAParameterizableType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +has 'parent_type_name' => ( + is => 'ro', + isa => 'Str', + required => 1, + documentation => "This attribute can be used for fetching type constraint(Moose::Meta::TypeConstraint):\n". + " my \$type_constraint = Moose::Util::TypeConstraints::find_type_constraint( \$exception->parent_type_name );\n", +); + +sub _build_message { + my $self = shift; + my $type_name = $self->type_name; + my $parent_type_name = $self->parent_type_name; + "The $type_name constraint cannot be used, because " + . "$parent_type_name doesn't subtype or coerce from a parameterizable type."; +} + +1; diff --git a/lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm b/lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm new file mode 100644 index 0000000..47d36a5 --- /dev/null +++ b/lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm @@ -0,0 +1,25 @@ +package Moose::Exception::TypeConstraintIsAlreadyCreated; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +use Moose::Util::TypeConstraints 'find_type_constraint'; + +has 'package_defined_in' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + my $type_name = $self->type_name; + my $type = find_type_constraint( $type_name ); + my $type_package_defined_in = $type->_package_defined_in; + my $package_defined_in = $self->package_defined_in; + return "The type constraint '$type_name' has already been created in $type_package_defined_in and cannot be created again in $package_defined_in"; +} + +1; diff --git a/lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm b/lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm new file mode 100644 index 0000000..f582290 --- /dev/null +++ b/lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm @@ -0,0 +1,12 @@ +package Moose::Exception::TypeParameterMustBeMooseMetaType; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::TypeConstraint'; + +sub _build_message { + "The type parameter must be a Moose meta type"; +} + +1; diff --git a/lib/Moose/Exception/UnableToCanonicalizeHandles.pm b/lib/Moose/Exception/UnableToCanonicalizeHandles.pm new file mode 100644 index 0000000..f546936 --- /dev/null +++ b/lib/Moose/Exception/UnableToCanonicalizeHandles.pm @@ -0,0 +1,19 @@ +package Moose::Exception::UnableToCanonicalizeHandles; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'handles' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +sub _build_message { + my $self = shift; + "Unable to canonicalize the 'handles' option with ".$self->handles; +} + +1; diff --git a/lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm b/lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm new file mode 100644 index 0000000..a6ef63a --- /dev/null +++ b/lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm @@ -0,0 +1,19 @@ +package Moose::Exception::UnableToCanonicalizeNonRolePackage; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'handles' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "Unable to canonicalize the 'handles' option with ".$self->handles." because its metaclass is not a Moose::Meta::Role"; +} + +1; diff --git a/lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm b/lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm new file mode 100644 index 0000000..1a09b9e --- /dev/null +++ b/lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm @@ -0,0 +1,21 @@ +package Moose::Exception::UnableToRecognizeDelegateMetaclass; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'delegate_metaclass' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +sub _build_message { + my $self = shift; + my $meta = $self->delegate_metaclass; + + return "Unable to recognize the delegate metaclass '$meta'"; +} + +1; diff --git a/lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm b/lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm new file mode 100644 index 0000000..c8349bf --- /dev/null +++ b/lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm @@ -0,0 +1,24 @@ +package Moose::Exception::UndefinedHashKeysPassedToMethod; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'hash_keys' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +has 'method_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "Hash keys passed to ".$self->method_name." must be defined"; +} + +1; diff --git a/lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm b/lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm new file mode 100644 index 0000000..6aabad1 --- /dev/null +++ b/lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm @@ -0,0 +1,23 @@ +package Moose::Exception::UnionCalledWithAnArrayRefAndAdditionalArgs; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +has 'array' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +has 'args' => ( + is => 'ro', + isa => 'ArrayRef', + required => 1 +); + +sub _build_message { + "union called with an array reference and additional arguments"; +} + +1; diff --git a/lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm b/lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm new file mode 100644 index 0000000..282718d --- /dev/null +++ b/lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm @@ -0,0 +1,11 @@ +package Moose::Exception::UnionTakesAtleastTwoTypeNames; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; + +sub _build_message { + "You must pass in at least 2 type names to make a union"; +} + +1; diff --git a/lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm b/lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm new file mode 100644 index 0000000..3ca0a7f --- /dev/null +++ b/lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm @@ -0,0 +1,48 @@ +package Moose::Exception::ValidationFailedForInlineTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Class'; + +has 'type_constraint_message' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +has 'value' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'new_member' => ( + is => 'ro', + isa => 'Bool', + default => 0, + predicate => 'is_a_new_member' +); + +sub _build_message { + my $self = shift; + + my $line1; + + if( $self->new_member ) { + $line1 = "A new member value for ".$self->attribute_name." does not pass its type constraint because: " + } + else { + $line1 = "Attribute (".$self->attribute_name.") does not pass the type constraint because: "; + } + + return $line1 . $self->type_constraint_message; +} + +1; diff --git a/lib/Moose/Exception/ValidationFailedForTypeConstraint.pm b/lib/Moose/Exception/ValidationFailedForTypeConstraint.pm new file mode 100644 index 0000000..d09b836 --- /dev/null +++ b/lib/Moose/Exception/ValidationFailedForTypeConstraint.pm @@ -0,0 +1,32 @@ +package Moose::Exception::ValidationFailedForTypeConstraint; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::Attribute'; + +has 'value' => ( + is => 'ro', + isa => 'Any', + required => 1, +); + +has 'type' => ( + is => 'ro', + isa => Moose::Util::TypeConstraints->duck_type(["get_message", "name"]), + required => 1 +); + +sub _build_message { + my $self = shift; + + my $error = $self->type->get_message( $self->value ); + + return $error unless $self->is_attribute_set; + + my $attribute_name = $self->attribute->name; + return + "Attribute ($attribute_name) does not pass the type constraint because: $error"; +} + +1; diff --git a/lib/Moose/Exception/WrapTakesACodeRefToBless.pm b/lib/Moose/Exception/WrapTakesACodeRefToBless.pm new file mode 100644 index 0000000..d833512 --- /dev/null +++ b/lib/Moose/Exception/WrapTakesACodeRefToBless.pm @@ -0,0 +1,25 @@ +package Moose::Exception::WrapTakesACodeRefToBless; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'code' => ( + is => 'ro', + isa => 'Any', + required => 1 +); + +has 'class' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "You must supply a CODE reference to bless, not (" . ( $self->code ? $self->code : 'undef' ) . ")"; +} + +1; diff --git a/lib/Moose/Exception/WrongTypeConstraintGiven.pm b/lib/Moose/Exception/WrongTypeConstraintGiven.pm new file mode 100644 index 0000000..9c3ea18 --- /dev/null +++ b/lib/Moose/Exception/WrongTypeConstraintGiven.pm @@ -0,0 +1,20 @@ +package Moose::Exception::WrongTypeConstraintGiven; +our $VERSION = '2.1405'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has [qw/required_type given_type attribute_name/] => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + "The type constraint for ".$self->attribute_name." must be a subtype of " + .$self->required_type." but it's a ".$self->given_type; +} + +1; diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm new file mode 100644 index 0000000..de9e93b --- /dev/null +++ b/lib/Moose/Exporter.pm @@ -0,0 +1,1065 @@ +package Moose::Exporter; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::Load qw(is_class_loaded); +use Class::MOP; +use List::MoreUtils qw( first_index uniq ); +use Moose::Util::MetaRole; +use Scalar::Util 1.11 qw(reftype); +use Sub::Exporter 0.980; +use Sub::Name qw(subname); + +use Moose::Util 'throw_exception'; + +my %EXPORT_SPEC; + +sub setup_import_methods { + my ( $class, %args ) = @_; + + $args{exporting_package} ||= caller(); + + $class->build_import_methods( + %args, + install => [qw(import unimport init_meta)] + ); +} + +# A reminder to intrepid Moose hackers +# there may be more than one level of exporter +# don't make doy cry. -- perigrin + +sub build_import_methods { + my ( $class, %args ) = @_; + + my $exporting_package = $args{exporting_package} ||= caller(); + + my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) }; + + $EXPORT_SPEC{$exporting_package} = \%args; + + my @exports_from = $class->_follow_also($exporting_package); + + my $export_recorder = {}; + my $is_reexport = {}; + + my $exports = $class->_make_sub_exporter_params( + [ $exporting_package, @exports_from ], + $export_recorder, + $is_reexport, + $args{meta_lookup}, # so that we don't pass through the default + ); + + my $exporter = $class->_make_exporter( + $exports, + $is_reexport, + $meta_lookup, + ); + + my %methods; + $methods{import} = $class->_make_import_sub( + $exporting_package, + $exporter, + \@exports_from, + $is_reexport, + $meta_lookup, + ); + + $methods{unimport} = $class->_make_unimport_sub( + $exporting_package, + $exports, + $export_recorder, + $is_reexport, + $meta_lookup, + ); + + $methods{init_meta} = $class->_make_init_meta( + $exporting_package, + \%args, + $meta_lookup, + ); + + my $package = Class::MOP::Package->initialize($exporting_package); + for my $to_install ( @{ $args{install} || [] } ) { + my $symbol = '&' . $to_install; + + next + unless $methods{$to_install} + && !$package->has_package_symbol($symbol); + $package->add_package_symbol( + $symbol, + subname( + $exporting_package . '::' . $to_install, $methods{$to_install} + ) + ); + } + + return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); +} + +sub _make_exporter { + my ($class, $exports, $is_reexport, $meta_lookup) = @_; + + return Sub::Exporter::build_exporter( + { + exports => $exports, + groups => { default => [':all'] }, + installer => sub { + my ($arg, $to_export) = @_; + my $meta = $meta_lookup->($arg->{into}); + + goto &Sub::Exporter::default_installer unless $meta; + + # don't overwrite existing symbols with our magically flagged + # version of it if we would install the same sub that's already + # in the importer + + my @filtered_to_export; + my %installed; + for (my $i = 0; $i < @{ $to_export }; $i += 2) { + my ($as, $cv) = @{ $to_export }[$i, $i + 1]; + + next if !ref($as) + && $meta->has_package_symbol('&' . $as) + && $meta->get_package_symbol('&' . $as) == $cv; + + push @filtered_to_export, $as, $cv; + $installed{$as} = 1 unless ref $as; + } + + Sub::Exporter::default_installer($arg, \@filtered_to_export); + + for my $name ( keys %{$is_reexport} ) { + no strict 'refs'; + no warnings 'once'; + next unless exists $installed{$name}; + _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } ); + } + }, + } + ); +} + +sub _follow_also { + my $class = shift; + my $exporting_package = shift; + + _die_if_cycle_found_in_also_list_for_package($exporting_package); + + return uniq( _follow_also_real($exporting_package) ); +} + +sub _follow_also_real { + my $exporting_package = shift; + my @also = _also_list_for_package($exporting_package); + + return map { $_, _follow_also_real($_) } @also; +} + +sub _also_list_for_package { + my $package = shift; + + if ( !exists $EXPORT_SPEC{$package} ) { + my $loaded = is_class_loaded($package); + + throw_exception( PackageDoesNotUseMooseExporter => package => $package, + is_loaded => $loaded + ); + } + + my $also = $EXPORT_SPEC{$package}{also}; + + return unless defined $also; + + return ref $also ? @$also : $also; +} + +# this is no Tarjan algorithm, but for the list sizes expected, +# brute force will probably be fine (and more maintainable) +sub _die_if_cycle_found_in_also_list_for_package { + my $package = shift; + _die_if_also_list_cycles_back_to_existing_stack( + [ _also_list_for_package($package) ], + [$package], + ); +} + +sub _die_if_also_list_cycles_back_to_existing_stack { + my ( $also_list, $existing_stack ) = @_; + + return unless @$also_list && @$existing_stack; + + for my $also_member (@$also_list) { + for my $stack_member (@$existing_stack) { + next unless $also_member eq $stack_member; + + throw_exception( CircularReferenceInAlso => also_parameter => $also_member, + stack => $existing_stack + ); + } + + _die_if_also_list_cycles_back_to_existing_stack( + [ _also_list_for_package($also_member) ], + [ $also_member, @$existing_stack ], + ); + } +} + +sub _parse_trait_aliases { + my $class = shift; + my ($package, $aliases) = @_; + + my @ret; + for my $alias (@$aliases) { + my $name; + if (ref($alias)) { + reftype($alias) eq 'ARRAY' + or throw_exception( InvalidArgumentsToTraitAliases => class_name => $class, + package_name => $package, + alias => $alias + ); + ($alias, $name) = @$alias; + } + else { + ($name = $alias) =~ s/.*:://; + } + push @ret, subname "${package}::${name}" => sub () { $alias }; + } + + return @ret; +} + +sub _make_sub_exporter_params { + my $class = shift; + my $packages = shift; + my $export_recorder = shift; + my $is_reexport = shift; + my $meta_lookup_override = shift; + + my %exports; + my $current_meta_lookup; + + for my $package ( @{$packages} ) { + my $args = $EXPORT_SPEC{$package} + or die "The $package package does not use Moose::Exporter\n"; + + $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup}; + $meta_lookup_override = $current_meta_lookup; + + my $meta_lookup = $current_meta_lookup + || sub { Class::MOP::class_of(shift) }; + + for my $name ( @{ $args->{with_meta} } ) { + my $sub = $class->_sub_from_package( $package, $name ) + or next; + + my $fq_name = $package . '::' . $name; + + $exports{$name} = $class->_make_wrapped_sub_with_meta( + $fq_name, + $sub, + $export_recorder, + $meta_lookup, + ) unless exists $exports{$name}; + } + + for my $name ( @{ $args->{with_caller} } ) { + my $sub = $class->_sub_from_package( $package, $name ) + or next; + + my $fq_name = $package . '::' . $name; + + $exports{$name} = $class->_make_wrapped_sub( + $fq_name, + $sub, + $export_recorder, + ) unless exists $exports{$name}; + } + + my @extra_exports = $class->_parse_trait_aliases( + $package, $args->{trait_aliases}, + ); + for my $name ( @{ $args->{as_is} }, @extra_exports ) { + my ( $sub, $coderef_name ); + + if ( ref $name ) { + $sub = $name; + + my $coderef_pkg; + ( $coderef_pkg, $coderef_name ) + = Class::MOP::get_code_info($name); + + if ( $coderef_pkg ne $package ) { + $is_reexport->{$coderef_name} = 1; + } + } + elsif ( $name =~ /^(.*)::([^:]+)$/ ) { + $sub = $class->_sub_from_package( "$1", "$2" ) + or next; + + $coderef_name = "$2"; + + if ( $1 ne $package ) { + $is_reexport->{$coderef_name} = 1; + } + } + else { + $sub = $class->_sub_from_package( $package, $name ) + or next; + + $coderef_name = $name; + } + + $export_recorder->{$sub} = 1; + + $exports{$coderef_name} = sub { $sub } + unless exists $exports{$coderef_name}; + } + } + + return \%exports; +} + +sub _sub_from_package { + my $sclass = shift; + my $package = shift; + my $name = shift; + + my $sub = do { + no strict 'refs'; + \&{ $package . '::' . $name }; + }; + + return $sub if defined &$sub; + + Carp::cluck "Trying to export undefined sub ${package}::${name}"; + + return; +} + +our $CALLER; + +sub _make_wrapped_sub { + my $self = shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; + + # We need to set the package at import time, so that when + # package Foo imports has(), we capture "Foo" as the + # package. This lets other packages call Foo::has() and get + # the right package. This is done for backwards compatibility + # with existing production code, not because this is a good + # idea ;) + return sub { + my $caller = $CALLER; + + my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller ); + + my $sub = subname( $fq_name => $wrapper ); + + $export_recorder->{$sub} = 1; + + return $sub; + }; +} + +sub _make_wrapped_sub_with_meta { + my $self = shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; + my $meta_lookup = shift; + + return sub { + my $caller = $CALLER; + + my $wrapper = $self->_late_curry_wrapper( + $sub, $fq_name, + $meta_lookup => $caller + ); + + my $sub = subname( $fq_name => $wrapper ); + + $export_recorder->{$sub} = 1; + + return $sub; + }; +} + +sub _curry_wrapper { + my $class = shift; + my $sub = shift; + my $fq_name = shift; + my @extra = @_; + + my $wrapper = sub { $sub->( @extra, @_ ) }; + if ( my $proto = prototype $sub ) { + + # XXX - Perl's prototype sucks. Use & to make set_prototype + # ignore the fact that we're passing "private variables" + &Scalar::Util::set_prototype( $wrapper, $proto ); + } + return $wrapper; +} + +sub _late_curry_wrapper { + my $class = shift; + my $sub = shift; + my $fq_name = shift; + my $extra = shift; + my @ex_args = @_; + + my $wrapper = sub { + + # resolve curried arguments at runtime via this closure + my @curry = ( $extra->(@ex_args) ); + return $sub->( @curry, @_ ); + }; + + if ( my $proto = prototype $sub ) { + + # XXX - Perl's prototype sucks. Use & to make set_prototype + # ignore the fact that we're passing "private variables" + &Scalar::Util::set_prototype( $wrapper, $proto ); + } + return $wrapper; +} + +sub _make_import_sub { + shift; + my $exporting_package = shift; + my $exporter = shift; + my $exports_from = shift; + my $is_reexport = shift; + my $meta_lookup = 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, @_ ) = _strip_traits(@_); + + my $metaclass; + ( $metaclass, @_ ) = _strip_metaclass(@_); + $metaclass + = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass ) + if defined $metaclass && length $metaclass; + + my $meta_name; + ( $meta_name, @_ ) = _strip_meta_name(@_); + + # 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 = _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; + + my $did_init_meta; + for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { + + # init_meta can apply a role, which when loaded uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + $c->init_meta( + for_class => $CALLER, + metaclass => $metaclass, + meta_name => $meta_name, + ); + $did_init_meta = 1; + } + + { + # The metaroles will use Moose::Role, which in turn uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + _apply_metaroles( + $CALLER, + [$class, @$exports_from], + $meta_lookup + ); + } + + if ( $did_init_meta && @{$traits} ) { + + # The traits will use Moose::Role, which in turn uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + _apply_meta_traits( $CALLER, $traits, $meta_lookup ); + } + elsif ( @{$traits} ) { + throw_exception( ClassDoesNotHaveInitMeta => class_name => $class, + traits => $traits + ); + } + + my ( undef, @args ) = @_; + my $extra = shift @args if ref $args[0] eq 'HASH'; + + $extra ||= {}; + if ( !$extra->{into} ) { + $extra->{into_level} ||= 0; + $extra->{into_level}++; + } + + $class->$exporter( $extra, @args ); + }; +} + +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 _strip_metaclass { + my $idx = first_index { ( $_ || '' ) eq '-metaclass' } @_; + + return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $metaclass = $_[ $idx + 1 ]; + + splice @_, $idx, 2; + + return ( $metaclass, @_ ); +} + +sub _strip_meta_name { + my $idx = first_index { ( $_ || '' ) eq '-meta_name' } @_; + + return ( 'meta', @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $meta_name = $_[ $idx + 1 ]; + + splice @_, $idx, 2; + + return ( $meta_name, @_ ); +} + +sub _apply_metaroles { + my ($class, $exports_from, $meta_lookup) = @_; + + my $metaroles = _collect_metaroles($exports_from); + my $base_class_roles = delete $metaroles->{base_class_roles}; + + my $meta = $meta_lookup->($class); + # for instance, Moose.pm uses Moose::Util::TypeConstraints + return unless $meta; + + Moose::Util::MetaRole::apply_metaroles( + for => $meta, + %$metaroles, + ) if keys %$metaroles; + + Moose::Util::MetaRole::apply_base_class_roles( + for => $meta, + roles => $base_class_roles, + ) if $meta->isa('Class::MOP::Class') + && $base_class_roles && @$base_class_roles; +} + +sub _collect_metaroles { + my ($exports_from) = @_; + + my @old_style_role_types = map { "${_}_roles" } qw( + metaclass + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class + ); + + my %class_metaroles; + my %role_metaroles; + my @base_class_roles; + my %old_style_roles; + + for my $exporter (@$exports_from) { + my $data = $EXPORT_SPEC{$exporter}; + + if (exists $data->{class_metaroles}) { + for my $type (keys %{ $data->{class_metaroles} }) { + push @{ $class_metaroles{$type} ||= [] }, + @{ $data->{class_metaroles}{$type} }; + } + } + + if (exists $data->{role_metaroles}) { + for my $type (keys %{ $data->{role_metaroles} }) { + push @{ $role_metaroles{$type} ||= [] }, + @{ $data->{role_metaroles}{$type} }; + } + } + + if (exists $data->{base_class_roles}) { + push @base_class_roles, @{ $data->{base_class_roles} }; + } + + for my $type (@old_style_role_types) { + if (exists $data->{$type}) { + push @{ $old_style_roles{$type} ||= [] }, + @{ $data->{$type} }; + } + } + } + + return { + (keys(%class_metaroles) + ? (class_metaroles => \%class_metaroles) + : ()), + (keys(%role_metaroles) + ? (role_metaroles => \%role_metaroles) + : ()), + (@base_class_roles + ? (base_class_roles => \@base_class_roles) + : ()), + %old_style_roles, + }; +} + +sub _apply_meta_traits { + my ( $class, $traits, $meta_lookup ) = @_; + + return unless @{$traits}; + + my $meta = $meta_lookup->($class); + + my $type = $meta->isa('Moose::Meta::Role') ? 'Role' + : $meta->isa('Class::MOP::Class') ? 'Class' + : confess('Cannot determine metaclass type for ' + . 'trait application. Meta isa ' + . ref $meta); + + my @resolved_traits = map { + ref $_ + ? $_ + : Moose::Util::resolve_metatrait_alias( $type => $_ ) + } @$traits; + + return unless @resolved_traits; + + my %args = ( for => $class ); + + if ( $meta->isa('Moose::Meta::Role') ) { + $args{role_metaroles} = { role => \@resolved_traits }; + } + else { + $args{class_metaroles} = { class => \@resolved_traits }; + } + + Moose::Util::MetaRole::apply_metaroles(%args); +} + +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; + my $is_reexport = shift; + my $meta_lookup = shift; + + return sub { + my $caller = scalar caller(); + Moose::Exporter->_remove_keywords( + $caller, + [ keys %{$exports} ], + $export_recorder, + $is_reexport, + ); + }; +} + +sub _remove_keywords { + shift; + my $package = shift; + my $keywords = shift; + my $recorded_exports = shift; + my $is_reexport = 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}; + + if ( $is_reexport->{$name} ) { + no strict 'refs'; + next + unless _export_is_flagged( + \*{ join q{::} => $package, $name } ); + } + + # and if it is from us, then undef the slot + delete ${ $package . '::' }{$name}; + } + } +} + +# maintain this for now for backcompat +# make sure to return a sub to install in the same circumstances as previously +# but this functionality now happens at the end of ->import +sub _make_init_meta { + shift; + my $class = shift; + my $args = shift; + my $meta_lookup = shift; + + my %old_style_roles; + for my $role ( + map {"${_}_roles"} + qw( + metaclass + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class + ) + ) { + $old_style_roles{$role} = $args->{$role} + if exists $args->{$role}; + } + + my %base_class_roles; + %base_class_roles = ( roles => $args->{base_class_roles} ) + if exists $args->{base_class_roles}; + + my %new_style_roles = map { $_ => $args->{$_} } + grep { exists $args->{$_} } qw( class_metaroles role_metaroles ); + + return unless %new_style_roles || %old_style_roles || %base_class_roles; + + return sub { + shift; + my %opts = @_; + $meta_lookup->($opts{for_class}); + }; +} + +sub import { + strict->import; + warnings->import; +} + +1; + +# ABSTRACT: make an import() and unimport() just like Moose.pm + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Exporter - make an import() and unimport() just like Moose.pm + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Moose; + + use Moose (); + use Moose::Exporter; + use Some::Random (); + + Moose::Exporter->setup_import_methods( + with_meta => [ 'has_rw', 'sugar2' ], + as_is => [ 'sugar3', \&Some::Random::thing, 'Some::Random::other_thing' ], + also => 'Moose', + ); + + sub has_rw { + my ( $meta, $name, %options ) = @_; + $meta->add_attribute( + $name, + is => 'rw', + %options, + ); + } + + # then later ... + package MyApp::User; + + use MyApp::Moose; + + has 'name' => ( is => 'ro' ); + has_rw 'size'; + thing; + other_thing; + + no MyApp::Moose; + +=head1 DESCRIPTION + +This module encapsulates the exporting of sugar functions in a +C<Moose.pm>-like manner. It does this by building custom C<import> and +C<unimport> methods for your module, based on a spec you provide. + +It also lets you "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>. This feature exists to let you bundle +a set of MooseX modules into a policy module that developers can use directly +instead of using Moose itself. + +To simplify writing exporter modules, C<Moose::Exporter> also imports +C<strict> and C<warnings> into your exporter module, as well as into +modules that use it. + +=head1 METHODS + +This module provides two public methods: + +=over 4 + +=item B<< Moose::Exporter->setup_import_methods(...) >> + +When you call this method, C<Moose::Exporter> builds custom C<import> and +C<unimport> methods for your module. The C<import> method +will export the functions you specify, and can also re-export functions +exported by some other module (like C<Moose.pm>). If you pass any parameters +for L<Moose::Util::MetaRole>, the C<import> method will also call +L<Moose::Util::MetaRole::apply_metaroles|Moose::Util::MetaRole/apply_metaroles> and +L<Moose::Util::MetaRole::apply_base_class_roles|Moose::Util::MetaRole/apply_base_class_roles> as needed, after making +sure the metaclass is initialized. + +The C<unimport> method cleans the caller's namespace of all the exported +functions. This includes any functions you re-export from other +packages. However, if the consumer of your package also imports those +functions from the original package, they will I<not> be cleaned. + +Note that if any of these methods already exist, they will not be +overridden, you will have to use C<build_import_methods> to get the +coderef that would be installed. + +This method accepts the following parameters: + +=over 8 + +=item * with_meta => [ ... ] + +This list of function I<names only> will be wrapped and then exported. The +wrapper will pass the metaclass object for the caller as its first argument. + +Many sugar functions will need to use this metaclass object to do something to +the calling package. + +=item * as_is => [ ... ] + +This list of function names or sub references will 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>). + +If you do export some other package's function, this function will never be +removed by the C<unimport> method. The reason for this is we cannot know if +the caller I<also> explicitly imported the sub themselves, and therefore wants +to keep it. + +=item * trait_aliases => [ ... ] + +This is a list of package names which should have shortened aliases exported, +similar to the functionality of L<aliased>. Each element in the list can be +either a package name, in which case the export will be named as the last +namespace component of the package, or an arrayref, whose first element is the +package to alias to, and second element is the alias to export. + +=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>. +Functions specified by C<with_meta> or C<as_is> take precedence over +functions exported by modules specified by C<also>, so that a module +can selectively override functions exported by another module. + +C<Moose::Exporter> also makes sure all these functions get removed +when C<unimport> is called. + +=item * meta_lookup => sub { ... } + +This is a function which will be called to provide the metaclass +to be operated upon by the exporter. This is an advanced feature +intended for use by package generator modules in the vein of +L<MooseX::Role::Parameterized> in order to simplify reusing sugar +from other modules that use C<Moose::Exporter>. This function is +used, for example, to select the metaclass to bind to functions +that are exported using the C<with_meta> option. + +This function will receive one parameter: the class name into which +the sugar is being exported. The default implementation is: + + sub { Class::MOP::class_of(shift) } + +Accordingly, this function is expected to return a metaclass. + +=back + +You can also provide parameters for L<Moose::Util::MetaRole::apply_metaroles|Moose::Util::MetaRole/apply_metaroles> +and L<Moose::Util::MetaRole::apply_base_class_roles|Moose::Util::MetaRole/apply_base_class_roles>. Specifically, valid parameters +are "class_metaroles", "role_metaroles", and "base_class_roles". + +=item B<< Moose::Exporter->build_import_methods(...) >> + +Returns three code refs, one for C<import>, one for C<unimport> and one for +C<init_meta>. + +Accepts the additional C<install> option, which accepts an arrayref of method +names to install into your exporting package. The valid options are C<import> +and C<unimport>. Calling C<setup_import_methods> is equivalent +to calling C<build_import_methods> with C<< install => [qw(import unimport)] >> +except that it doesn't also return the methods. + +The C<import> method is built using L<Sub::Exporter>. This means that it can +take a hashref of the form C<< { into => $package } >> to specify the package +it operates on. + +Used by C<setup_import_methods>. + +=back + +=head1 IMPORTING AND init_meta + +If you want to set an alternative base object class or metaclass class, see +above for details on how this module can call L<Moose::Util::MetaRole> for +you. + +If you want to do something that is not supported by this module, 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 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Intro.pod b/lib/Moose/Intro.pod new file mode 100644 index 0000000..689dd20 --- /dev/null +++ b/lib/Moose/Intro.pod @@ -0,0 +1,77 @@ +# PODNAME: Moose::Intro +# ABSTRACT: Expanded into Moose::Manual, so go read that + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Intro - Expanded into Moose::Manual, so go read that + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The intro has been replaced by L<Moose::Manual>. This POD document +still exists for the benefit of anyone out there who might've linked +to it in the past. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual.pod b/lib/Moose/Manual.pod new file mode 100644 index 0000000..b944d8a --- /dev/null +++ b/lib/Moose/Manual.pod @@ -0,0 +1,334 @@ +# PODNAME: Moose::Manual +# ABSTRACT: What is Moose, and how do I use it? + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual - What is Moose, and how do I use it? + +=head1 VERSION + +version 2.1405 + +=head1 WHAT IS MOOSE? + +Moose is a I<complete> object system for Perl 5. Consider any modern +object-oriented language (which Perl 5 definitely isn't). It provides +keywords for attribute declaration, object construction, inheritance, +and maybe more. 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<define your class +declaratively>, without needing to know about blessed hashrefs, +accessor methods, and so on. + +With Moose, you can concentrate on the I<logical> structure of your +classes, focusing on "what" rather than "how". A class definition with +Moose reads like a list of very concise English sentences. + +Moose is built on 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 the 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 +Perl 5 power tools in high-level declarative APIs which are easy to +use. Best of all, you don't need to be a wizard to use it. + +But 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', + ); + + no Moose; + __PACKAGE__->meta->make_immutable; + +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; + } + + no Moose; + __PACKAGE__->meta->make_immutable; + +When ready to instantiate your class in an application, use it in the +"traditional" Perl manner: + + use User; + + my $user = User->new( + first_name => 'Example', + last_name => 'User', + password => 'letmein', + ); + + $user->login('letmein'); + + say $user->date_of_last_login; + +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. + +=head1 TABLE OF CONTENTS + +This manual consists of a number of documents. + +=over 4 + +=item L<Moose::Manual::Concepts> + +Introduces Moose concepts, and contrasts them against "old school" +Perl 5 OO. + +=item L<Moose::Manual::Unsweetened> + +Shows two example classes, each written first with Moose and then with +"plain old Perl 5". + +=item L<Moose::Manual::Classes> + +How do you make use of Moose in your classes? Now that I'm a Moose, +how do I subclass something? + +=item L<Moose::Manual::Attributes> + +Attributes are a core part of the Moose OO system. An attribute is a +piece of data that an object has. Moose has a lot of attribute-related +features! + +=item L<Moose::Manual::Delegation> + +Delegation is a powerful way to make use of attributes which are +themselves objects. + +=item L<Moose::Manual::Construction> + +Learn how objects are built in Moose, and in particular about the +C<BUILD> and C<BUILDARGS> methods. Also covers object destruction +with C<DEMOLISH>. + +=item L<Moose::Manual::MethodModifiers> + +A method modifier lets you say "before calling method X, do this +first", or "wrap method X in this code". Method modifiers are +particularly handy in roles and with attribute accessors. + +=item L<Moose::Manual::Roles> + +A role is something a class does (like "Debuggable" or +"Printable"). Roles provide a way of adding behavior to classes that +is orthogonal to inheritance. + +=item L<Moose::Manual::Types> + +Moose's type system lets you strictly define what values an attribute +can contain. + +=item L<Moose::Manual::MOP> + +Moose's meta API system lets you ask classes about their parents, +children, methods, attributes, etc. + +=item L<Moose::Manual::MooseX> + +This document describes a few of the most useful Moose extensions on +CPAN. + +=item L<Moose::Manual::BestPractices> + +Moose has a lot of features, and there's definitely more than one way +to do it. However, we think that picking a subset of these features +and using them consistently makes everyone's life easier. + +=item L<Moose::Manual::FAQ> + +Frequently asked questions about Moose. + +=item L<Moose::Manual::Resources> + +Links to various tutorials, videos, blogs, presentations, interviews, etc... + +=item L<Moose::Manual::Contributing> + +Interested in hacking on Moose? Read this. + +=item L<Moose::Manual::Delta> + +This document details backwards-incompatibilities and other major +changes to Moose. + +=back + +=head1 JUSTIFICATION + +If you're still asking yourself "Why do I need this?", then this +section is for you. + +=over 4 + +=item Another object system!?!? + +Yes, we know there are many, many ways to build objects in Perl 5, +many 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 many +people and companies. There are Moose applications which have been in +production with little or no issue now for years. We consider it +highly stable and we are committed 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 or +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 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Attributes.pod b/lib/Moose/Manual/Attributes.pod new file mode 100644 index 0000000..cf41c83 --- /dev/null +++ b/lib/Moose/Manual/Attributes.pod @@ -0,0 +1,697 @@ +# PODNAME: Moose::Manual::Attributes +# ABSTRACT: Object attributes with Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Attributes - Object attributes with Moose + +=head1 VERSION + +version 2.1405 + +=head1 INTRODUCTION + +Moose attributes have many properties, and attributes are probably the +single most powerful and flexible part of Moose. You can create a +powerful class simply by declaring attributes. In fact, it's possible +to have classes that consist solely of attribute declarations. + +An attribute is a property that every member of a class has. For +example, we might say that "every C<Person> object has a first name and +last name". Attributes can be optional, so that we can say "some C<Person> +objects have a social security number (and some don't)". + +At its simplest, an attribute can be thought of as a named value (as +in a hash) that can be read and set. However, attributes can also have +defaults, type constraints, delegation and much more. + +In other languages, attributes are also referred to as slots or +properties. + +=head1 ATTRIBUTE OPTIONS + +Use the C<has> function to declare an attribute: + + package Person; + + use Moose; + + has 'first_name' => ( is => 'rw' ); + +This says that all C<Person> objects have an optional read-write +"first_name" attribute. + +=head2 Read-write vs. read-only + +The options passed to C<has> define the properties of the attribute. There are +many options, but in the simplest form you just need to set C<is>, which can +be either C<ro> (read-only) or C<rw> (read-write). When an attribute is C<rw>, +you can change it by passing a value to its accessor. When an attribute is +C<ro>, you may only read the current value of the attribute. + +In fact, you could even omit C<is>, but that gives you an attribute +that has no accessor. This can be useful with other attribute options, +such as C<handles>. However, if your attribute generates I<no> +accessors, Moose will issue a warning, because that usually means the +programmer forgot to say the attribute is read-only or read-write. If +you really mean to have no accessors, you can silence this warning by +setting C<is> to C<bare>. + +=head2 Accessor methods + +Each attribute has one or more accessor methods. An accessor lets you +read and write the value of that attribute for an object. + +By default, the accessor method has the same name as the attribute. If +you declared your attribute as C<ro> then your accessor will be +read-only. If you declared it as C<rw>, you get a read-write +accessor. Simple. + +Given our C<Person> example above, we now have a single C<first_name> +accessor that can read or write a C<Person> object's C<first_name> +attribute's value. + +If you want, you can also explicitly specify the method names to be +used for reading and writing an attribute's value. This is +particularly handy when you'd like an attribute to be publicly +readable, but only privately settable. For example: + + has 'weight' => ( + is => 'ro', + writer => '_set_weight', + ); + +This might be useful if weight is calculated based on other methods. +For example, every time the C<eat> method is called, we might adjust +weight. This lets us hide the implementation details of weight +changes, but still provide the weight value to users of the class. + +Some people might prefer to have distinct methods for reading and +writing. In I<Perl Best Practices>, Damian Conway recommends that +reader methods start with "get_" and writer methods start with "set_". + +We can do exactly that by providing names for both the C<reader> and +C<writer> methods: + + has 'weight' => ( + is => 'rw', + reader => 'get_weight', + writer => 'set_weight', + ); + +If you're thinking that doing this over and over would be insanely +tedious, you're right! Fortunately, Moose provides a powerful +extension system that lets you override the default naming +conventions. See L<Moose::Manual::MooseX> for more details. + +=head2 Predicate and clearer methods + +Moose allows you to explicitly distinguish between a false or +undefined attribute value and an attribute which has not been set. If +you want to access this information, you must define clearer and +predicate methods for an attribute. + +A predicate method tells you whether or not a given attribute is +currently set. Note that an attribute can be explicitly set to +C<undef> or some other false value, but the predicate will return +true. + +The clearer method unsets the attribute. This is I<not> the +same as setting the value to C<undef>, but you can only distinguish +between them if you define a predicate method! + +Here's some code to illustrate the relationship between an accessor, +predicate, and clearer method. + + package Person; + + use Moose; + + has 'ssn' => ( + is => 'rw', + clearer => 'clear_ssn', + predicate => 'has_ssn', + ); + + ... + + my $person = Person->new(); + $person->has_ssn; # false + + $person->ssn(undef); + $person->ssn; # returns undef + $person->has_ssn; # true + + $person->clear_ssn; + $person->ssn; # returns undef + $person->has_ssn; # false + + $person->ssn('123-45-6789'); + $person->ssn; # returns '123-45-6789' + $person->has_ssn; # true + + my $person2 = Person->new( ssn => '111-22-3333'); + $person2->has_ssn; # true + +By default, Moose does not make a predicate or clearer for you. You must +explicitly provide names for them, and then Moose will create the methods +for you. + +=head2 Required or not? + +By default, all attributes are optional, and do not need to be +provided at object construction time. If you want to make an attribute +required, simply set the C<required> option to true: + + has 'name' => ( + is => 'ro', + required => 1, + ); + +There are a couple caveats worth mentioning in regards to what +"required" actually means. + +Basically, all it says is that this attribute (C<name>) must be provided to +the constructor, or be lazy with either a default or a builder. It does not +say anything about its value, so it could be C<undef>. + +If you define a clearer method on a required attribute, the clearer +I<will> work, so even a required attribute can be unset after object +construction. + +This means that if you do make an attribute required, providing a +clearer doesn't make much sense. In some cases, it might be handy to +have a I<private> C<clearer> and C<predicate> for a required +attribute. + +=head2 Default and builder methods + +Attributes can have default values, and Moose provides two ways to +specify that default. + +In the simplest form, you simply provide a non-reference scalar value +for the C<default> option: + + has 'size' => ( + is => 'ro', + default => 'medium', + predicate => 'has_size', + ); + +If the size attribute is not provided to the constructor, then it ends +up being set to C<medium>: + + my $person = Person->new(); + $person->size; # medium + $person->has_size; # true + +You can also provide a subroutine reference for C<default>. This +reference will be called as a method on the object. + + has 'size' => ( + is => 'ro', + default => + sub { ( 'small', 'medium', 'large' )[ int( rand 3 ) ] }, + predicate => 'has_size', + ); + +This is a trivial example, but it illustrates the point that the subroutine +will be called for every new object created. + +When you provide a C<default> subroutine reference, it is called as a +method on the object, with no additional parameters: + + has 'size' => ( + is => 'ro', + default => sub { + my $self = shift; + + return $self->height > 200 ? 'large' : 'average'; + }, + ); + +When the C<default> is called during object construction, it may be +called before other attributes have been set. If your default is +dependent on other parts of the object's state, you can make the +attribute C<lazy>. Laziness is covered in the next section. + +If you want to use a reference of any sort as the default value, you +must return it from a subroutine. + + has 'mapping' => ( + is => 'ro', + default => sub { {} }, + ); + +This is necessary because otherwise Perl would instantiate the reference +exactly once, and it would be shared by all objects: + + has 'mapping' => ( + is => 'ro', + default => {}, # wrong! + ); + +Moose will throw an error if you pass a bare non-subroutine reference +as the default. + +If Moose allowed this then the default mapping attribute could easily +end up shared across many objects. Instead, wrap it in a subroutine +reference as we saw above. + +This is a bit awkward, but it's just the way Perl works. + +As an alternative to using a subroutine reference, you can supply a C<builder> +method for your attribute: + + has 'size' => ( + is => 'ro', + builder => '_build_size', + predicate => 'has_size', + ); + + sub _build_size { + return ( 'small', 'medium', 'large' )[ int( rand 3 ) ]; + } + +This has several advantages. First, it moves a chunk of code to its own named +method, which improves readability and code organization. Second, because this +is a I<named> method, it can be subclassed or provided by a role. + +We strongly recommend that you use a C<builder> instead of a +C<default> for anything beyond the most trivial default. + +A C<builder>, just like a C<default>, is called as a method on the +object with no additional parameters. + +=head3 Builders allow subclassing + +Because the C<builder> is called I<by name>, it goes through Perl's +method resolution. This means that builder methods are both +inheritable and overridable. + +If we subclass our C<Person> class, we can override C<_build_size>: + + package Lilliputian; + + use Moose; + extends 'Person'; + + sub _build_size { return 'small' } + +=head3 Builders work well with roles + +Because builders are called by name, they work well with roles. For +example, a role could provide an attribute but require that the +consuming class provide the C<builder>: + + package HasSize; + use Moose::Role; + + requires '_build_size'; + + has 'size' => ( + is => 'ro', + lazy => 1, + builder => '_build_size', + ); + + package Lilliputian; + use Moose; + + with 'HasSize'; + + sub _build_size { return 'small' } + +Roles are covered in L<Moose::Manual::Roles>. + +=head2 Laziness + +Moose lets you defer attribute population by making an attribute +C<lazy>: + + has 'size' => ( + is => 'ro', + lazy => 1, + builder => '_build_size', + ); + +When C<lazy> is true, the default is not generated until the reader +method is called, rather than at object construction time. There are +several reasons you might choose to do this. + +First, if the default value for this attribute depends on some other +attributes, then the attribute I<must> be C<lazy>. During object +construction, defaults are not generated in a predictable order, so +you cannot count on some other attribute being populated when +generating a default. + +Second, there's often no reason to calculate a default before it's +needed. Making an attribute C<lazy> lets you defer the cost until the +attribute is needed. If the attribute is I<never> needed, you save +some CPU time. + +We recommend that you make any attribute with a builder or non-trivial +default C<lazy> as a matter of course. + +=head3 Lazy defaults and C<$_> + +Please note that a lazy default or builder can be called anywhere, even inside +a C<map> or C<grep>. This means that if your default sub or builder changes +C<$_>, something weird could happen. You can prevent this by adding C<local +$_> inside your default or builder. + +=head2 Constructor parameters (C<init_arg>) + +By default, each attribute can be passed by name to the class's +constructor. On occasion, you may want to use a different name for +the constructor parameter. You may also want to make an attribute +unsettable via the constructor. + +You can do either of these things with the C<init_arg> option: + + has 'bigness' => ( + is => 'ro', + init_arg => 'size', + ); + +Now we have an attribute named "bigness", but we pass C<size> to the +constructor. + +Even more useful is the ability to disable setting an attribute via +the constructor. This is particularly handy for private attributes: + + has '_genetic_code' => ( + is => 'ro', + lazy => 1, + builder => '_build_genetic_code', + init_arg => undef, + ); + +By setting the C<init_arg> to C<undef>, we make it impossible to set +this attribute when creating a new object. + +=head2 Weak references + +Moose has built-in support for weak references. If you set the +C<weak_ref> option to a true value, then it will call +C<Scalar::Util::weaken> whenever the attribute is set: + + has 'parent' => ( + is => 'rw', + weak_ref => 1, + ); + + $node->parent($parent_node); + +This is very useful when you're building objects that may contain +circular references. + +When the object in a weak reference goes out of scope, the attribute's value +will become C<undef> "behind the scenes". This is done by the Perl interpreter +directly, so Moose does not see this change. This means that triggers don't +fire, coercions aren't applied, etc. + +The attribute is not cleared, so a predicate method for that attribute will +still return true. Similarly, when the attribute is next accessed, a default +value will not be generated. + +=head2 Triggers + +A C<trigger> is a subroutine that is called whenever the attribute is +set: + + has 'size' => ( + is => 'rw', + trigger => \&_size_set, + ); + + sub _size_set { + my ( $self, $size, $old_size ) = @_; + + my $msg = $self->name; + + if ( @_ > 2 ) { + $msg .= " - old size was $old_size"; + } + + $msg .= " - size is now $size"; + warn $msg; + } + +The trigger is called I<after> an attribute's value is set. It is +called as a method on the object, and receives the new and old values as +its arguments. If the attribute had not previously been set at all, +then only the new value is passed. This lets you distinguish between +the case where the attribute had no value versus when the old value was C<undef>. + +This differs from an C<after> method modifier in two ways. First, a +trigger is only called when the attribute is set, as opposed to +whenever the accessor method is called (for reading or +writing). Second, it is also called when an attribute's value is +passed to the constructor. + +However, triggers are I<not> called when an attribute is populated +from a C<default> or C<builder>. + +=head2 Attribute types + +Attributes can be restricted to only accept certain types: + + has 'first_name' => ( + is => 'ro', + isa => 'Str', + ); + +This says that the C<first_name> attribute must be a string. + +Moose also provides a shortcut for specifying that an attribute only +accepts objects that do a certain role: + + has 'weapon' => ( + is => 'rw', + does => 'MyApp::Weapon', + ); + +See the L<Moose::Manual::Types> documentation for a complete +discussion of Moose's type system. + +=head2 Delegation + +An attribute can define methods which simply delegate to its value: + + has 'hair_color' => ( + is => 'ro', + isa => 'Graphics::Color::RGB', + handles => { hair_color_hex => 'as_hex_string' }, + ); + +This adds a new method, C<hair_color_hex>. When someone calls +C<hair_color_hex>, internally, the object just calls C<< +$self->hair_color->as_hex_string >>. + +See L<Moose::Manual::Delegation> for documentation on how to set up +delegation methods. + +=head2 Attribute traits and metaclasses + +One of Moose's best features is that it can be extended in all sorts of ways +through the use of metaclass traits and custom metaclasses. + +You can apply one or more traits to an attribute: + + use MooseX::MetaDescription; + + has 'size' => ( + is => 'ro', + traits => ['MooseX::MetaDescription::Meta::Trait'], + description => { + html_widget => 'text_input', + serialize_as => 'element', + }, + ); + +The advantage of traits is that you can mix more than one of them +together easily (in fact, a trait is just a role under the hood). + +There are a number of MooseX modules on CPAN which provide useful +attribute metaclasses and traits. See L<Moose::Manual::MooseX> for +some examples. You can also write your own metaclasses and traits. See +the "Meta" and "Extending" recipes in L<Moose::Cookbook> for examples. + +=head2 Native Delegations + +Native delegations allow you to delegate to standard Perl data structures as +if they were objects. + +For example, we can pretend that an array reference has methods like +C<push()>, C<shift()>, C<map()>, C<count()>, and more. + + has 'options' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + all_options => 'elements', + add_option => 'push', + map_options => 'map', + option_count => 'count', + sorted_options => 'sort', + }, + ); + +See L<Moose::Manual::Delegation> for more details. + +=head1 ATTRIBUTE INHERITANCE + +By default, a child inherits all of its parent class(es)' attributes +as-is. However, you can change most aspects of the inherited attribute in the +child class. You cannot change any of its associated method names (reader, +writer, predicate, etc). + +To override an attribute, you simply prepend its name with a plus sign +(C<+>): + + package LazyPerson; + + use Moose; + + extends 'Person'; + + has '+first_name' => ( + lazy => 1, + default => 'Bill', + ); + +Now the C<first_name> attribute in C<LazyPerson> is lazy, and defaults +to C<'Bill'>. + +We recommend that you exercise caution when changing the type (C<isa>) +of an inherited attribute. + +=head1 MULTIPLE ATTRIBUTE SHORTCUTS + +If you have a number of attributes that differ only by name, you can declare +them all at once: + + package Point; + + use Moose; + + has [ 'x', 'y' ] => ( is => 'ro', isa => 'Int' ); + +Also, because C<has> is just a function call, you can call it in a loop: + + for my $name ( qw( x y ) ) { + my $builder = '_build_' . $name; + has $name => ( is => 'ro', isa => 'Int', builder => $builder ); + } + +=head1 MORE ON ATTRIBUTES + +Moose attributes are a big topic, and this document glosses over a few +aspects. We recommend that you read the L<Moose::Manual::Delegation> +and L<Moose::Manual::Types> documents to get a more complete +understanding of attribute features. + +=head1 A FEW MORE OPTIONS + +Moose has lots of attribute options. The ones listed below are +superseded by some more modern features, but are covered for the sake +of completeness. + +=head2 The C<documentation> option + +You can provide a piece of documentation as a string for an attribute: + + has 'first_name' => ( + is => 'rw', + documentation => q{The person's first (personal) name}, + ); + +Moose does absolutely nothing with this information other than store +it. + +=head2 The C<auto_deref> option + +If your attribute is an array reference or hash reference, the +C<auto_deref> option will make Moose dereference the value when it is +returned from the reader method I<in list context>: + + my %map = $object->mapping; + +This option only works if your attribute is explicitly typed as an +C<ArrayRef> or C<HashRef>. When the reader is called in I<scalar> context, +the reference itself is returned. + +However, we recommend that you use L<Moose::Meta::Attribute::Native> traits +for these types of attributes, which gives you much more control over how +they are accessed and manipulated. See also +L<Moose::Manual::BestPractices#Use_Moose::Meta::Attribute::Native_traits_instead_of_auto_deref>. + +=head2 Initializer + +Moose provides an attribute option called C<initializer>. This is called when +the attribute's value is being set in the constructor, and lets you change the +value before it is set. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/BestPractices.pod b/lib/Moose/Manual/BestPractices.pod new file mode 100644 index 0000000..0f102b4 --- /dev/null +++ b/lib/Moose/Manual/BestPractices.pod @@ -0,0 +1,292 @@ +# PODNAME: Moose::Manual::BestPractices +# ABSTRACT: Get the most out of Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::BestPractices - Get the most out of Moose + +=head1 VERSION + +version 2.1405 + +=head1 RECOMMENDATIONS + +Moose has a lot of features, and there's definitely more than one way +to do it. However, we think that picking a subset of these features +and using them consistently makes everyone's life easier. + +Of course, as with any list of "best practices", these are really just +opinions. Feel free to ignore us. + +=head2 C<namespace::autoclean> and immutabilize + +We recommend that you remove the Moose sugar and end your Moose class +definitions by making your class immutable. + + package Person; + + use Moose; + use namespace::autoclean; + + # extends, roles, attributes, etc. + + # methods + + __PACKAGE__->meta->make_immutable; + + 1; + +The C<use namespace::autoclean> bit is simply good code hygiene, as it removes +imported symbols from your class's namespace at the end of your package's +compile cycle, including Moose keywords. Once the class has been built, these +keywords are not needed. (This is preferred to placing C<no Moose> at the end +of your package). + +The C<make_immutable> call allows Moose to speed up a lot of things, most +notably object construction. The trade-off is that you can no longer change +the class definition. + +=head2 Never override C<new> + +Overriding C<new> is a very bad practice. Instead, you should use a +C<BUILD> or C<BUILDARGS> methods to do the same thing. When you +override C<new>, Moose can no longer inline a constructor when your +class is immutabilized. + +There are two good reasons to override C<new>. One, you are writing a +MooseX extension that provides its own L<Moose::Object> subclass +I<and> a subclass of L<Moose::Meta::Method::Constructor> to inline the +constructor. Two, you are subclassing a non-Moose parent. + +If you know how to do that, you know when to ignore this best practice +;) + +=head2 Always call the original/parent C<BUILDARGS> + +If you C<override> the C<BUILDARGS> method in your class, make sure to play +nice and call C<super()> to handle cases you're not checking for explicitly. + +The default C<BUILDARGS> method in L<Moose::Object> handles both a +list and hashref of named parameters correctly, and also checks for a +I<non-hashref> single argument. + +=head2 Provide defaults whenever possible, otherwise use C<required> + +When your class provides defaults, this makes constructing new objects +simpler. If you cannot provide a default, consider making the +attribute C<required>. + +If you don't do either, an attribute can simply be left unset, +increasing the complexity of your object, because it has more possible +states that you or the user of your class must account for. + +=head2 Use C<builder> instead of C<default> most of the time + +Builders can be inherited, they have explicit names, and they're just +plain cleaner. + +However, I<do> use a default when the default is a non-reference, +I<or> when the default is simply an empty reference of some sort. + +Also, keep your builder methods private. + +=head2 Be C<lazy> + +Lazy is good, and often solves initialization ordering problems. It's also +good for deferring work that may never have to be done. Make your attributes +C<lazy> unless they're C<required> or have trivial defaults. + +=head2 Consider keeping clearers and predicates private + +Does everyone I<really> need to be able to clear an attribute? +Probably not. Don't expose this functionality outside your class +by default. + +Predicates are less problematic, but there's no reason to make your +public API bigger than it has to be. + +=head2 Avoid C<lazy_build> + +As described above, you rarely actually need a clearer or a predicate. +C<lazy_build> adds both to your public API, which exposes you to use cases that +you must now test for. It's much better to avoid adding them until you really +need them - use explicit C<lazy> and C<builder> options instead. + +=head2 Default to read-only, and consider keeping writers private + +Making attributes mutable just means more complexity to account for in +your program. The alternative to mutable state is to encourage users +of your class to simply make new objects as needed. + +If you I<must> make an attribute read-write, consider making the +writer a separate private method. Narrower APIs are easy to maintain, +and mutable state is trouble. + +In order to declare such attributes, provide a private C<writer> +parameter: + + has pizza => ( + is => 'ro', + isa => 'Pizza', + writer => '_pizza', + ); + +=head2 Think twice before changing an attribute's type in a subclass + +Down this path lies great confusion. If the attribute is an object +itself, at least make sure that it has the same interface as the type +of object in the parent class. + +=head2 Don't use the C<initializer> feature + +Don't know what we're talking about? That's fine. + +=head2 Use L<Moose::Meta::Attribute::Native> traits instead of C<auto_deref> + +The C<auto_deref> feature is a bit troublesome. Directly exposing a complex +attribute is ugly. Instead, consider using L<Moose::Meta::Attribute::Native> +traits to define an API that only exposes the necessary pieces of +functionality. + +=head2 Always call C<inner> in the most specific subclass + +When using C<augment> and C<inner>, we recommend that you call +C<inner> in the most specific subclass of your hierarchy. This makes +it possible to subclass further and extend the hierarchy without +changing the parents. + +=head2 Namespace your types + +Use some sort of namespacing convention for type names. We recommend something +like "MyApp::Type::Foo". We also recommend considering L<MooseX::Types>. + +=head2 Do not coerce Moose built-ins directly + +If you define a coercion for a Moose built-in like C<ArrayRef>, this +will affect every application in the Perl interpreter that uses this +type. + + # very naughty! + coerce 'ArrayRef' + => from Str + => via { [ split /,/ ] }; + +Instead, create a subtype and coerce that: + + subtype 'My::ArrayRef' => as 'ArrayRef'; + + coerce 'My::ArrayRef' + => from 'Str' + => via { [ split /,/ ] }; + +=head2 Do not coerce class names directly + +Just as with Moose built-in types, a class type is global for the +entire interpreter. If you add a coercion for that class name, it can +have magical side effects elsewhere: + + # also very naughty! + coerce 'HTTP::Headers' + => from 'HashRef' + => via { HTTP::Headers->new( %{$_} ) }; + +Instead, we can create an "empty" subtype for the coercion: + + subtype 'My::HTTP::Headers' => as class_type('HTTP::Headers'); + + coerce 'My::HTTP::Headers' + => from 'HashRef' + => via { HTTP::Headers->new( %{$_} ) }; + +=head2 Use coercion instead of unions + +Consider using a type coercion instead of a type union. This was +covered in L<Moose::Manual::Types>. + +=head2 Define all your types in one module + +Define all your types and coercions in one module. This was also +covered in L<Moose::Manual::Types>. + +=head1 BENEFITS OF BEST PRACTICES + +Following these practices has a number of benefits. + +It helps ensure that your code will play nice with others, making it +more reusable and easier to extend. + +Following an accepted set of idioms will make maintenance easier, +especially when someone else has to maintain your code. It will also +make it easier to get support from other Moose users, since your code +will be easier to digest quickly. + +Some of these practices are designed to help Moose do the right thing, +especially when it comes to immutabilization. This means your code +will be faster when immutabilized. + +Many of these practices also help get the most out of meta +programming. If you used an overridden C<new> to do type coercion by +hand, rather than defining a real coercion, there is no introspectable +metadata. This sort of thing is particularly problematic for MooseX +extensions which rely on introspection to do the right thing. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Classes.pod b/lib/Moose/Manual/Classes.pod new file mode 100644 index 0000000..37553d0 --- /dev/null +++ b/lib/Moose/Manual/Classes.pod @@ -0,0 +1,218 @@ +# PODNAME: Moose::Manual::Classes +# ABSTRACT: Making your classes use Moose (and subclassing) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Classes - Making your classes use Moose (and subclassing) + +=head1 VERSION + +version 2.1405 + +=head1 USING MOOSE + +Using Moose is very simple, you just C<use Moose>: + + package Person; + + use Moose; + +That's it, you've made a class with Moose! + +There's actually a lot going on here under the hood, so let's step +through it. + +When you load L<Moose>, a bunch of sugar functions are exported into your +class, such as C<extends>, C<has>, C<with>, and more. These functions are what +you use to define your class. For example, you might define an attribute ... + + package Person; + + use Moose; + + has 'ssn' => ( is => 'rw' ); + +Attributes are described in the L<Moose::Manual::Attributes> +documentation. + +Loading Moose also enables the C<strict> and C<warnings> pragmas in your +class. + +When you load Moose, your class will become a subclass of +L<Moose::Object>. The L<Moose::Object> class provides a default +constructor and destructor, as well as object construction helper +methods. You can read more about this in the +L<Moose::Manual::Construction> document. + +As a convenience, Moose creates a new class type for your class. See +the L<Moose::Manual::Types> document to learn more about types. + +It also creates a L<Moose::Meta::Class> object for your class. This +metaclass object is now available by calling a C<meta> method on your +class, for example C<< Person->meta >>. + +The metaclass object provides an introspection API for your class. It +is also used by Moose itself under the hood to add attributes, define +parent classes, and so on. In fact, all of Moose's sugar does the real +work by calling methods on this metaclass object (and other meta API +objects). + +=head1 SUBCLASSING + +Moose provides a simple sugar function for declaring your parent +classes, C<extends>: + + package User; + + use Moose; + + extends 'Person'; + + has 'username' => ( is => 'rw' ); + +Note that each call to C<extends> will I<reset> your parents. For +multiple inheritance you must provide all the parents at once, +C<extends 'Foo', 'Bar'>. + +When you call C<extends> Moose will try to load any classes you pass. + +You can use Moose to extend a non-Moose parent. However, when you do +this, you will inherit the parent class's constructor (assuming it is +also called C<new>). In that case, you will have to take care of +initializing attributes manually, either in the parent's constructor, +or in your subclass, and you will lose a lot of Moose magic. + +See the L<MooseX::NonMoose> module on CPAN if you're interested in extending +non-Moose parent classes with Moose child classes. + +=head1 CLEANING UP MOOSE DROPPINGS + +Moose exports a number of functions into your class. It's a good idea to +remove these sugar functions from your class's namespace, so that C<< +Person->can('has') >> will no longer return true. + +There are several ways to do this. We recommend using L<namespace::autoclean>, +a CPAN module. Not only will it remove Moose exports, it will also remove +any other exports. + + package Person; + + use namespace::autoclean; + + use Moose; + +If you absolutely can't use a CPAN module (but can use Moose?), you can write +C<no Moose> at the end of your class. This will remove any Moose exports in +your class. + + package Person; + + use Moose; + + has 'ssn' => ( is => 'rw' ); + + no Moose; + +=head1 MAKING IT FASTER + +Moose has a feature called "immutabilization" that you can use to +greatly speed up your classes at runtime. However, using it incurs +a cost when your class is first being loaded. When you make your class +immutable you tell Moose that you will not be changing it in the +future. You will not be adding any more attributes, methods, roles, etc. + +This allows Moose to generate code specific to your class. In +particular, it creates an "inline" constructor, making object +construction much faster. + +To make your class immutable you simply call C<make_immutable> on your +class's metaclass object. + + __PACKAGE__->meta->make_immutable; + +=head2 Immutabilization and C<new()> + +If you override C<new()> in your class, then the immutabilization code +will not be able to provide an optimized constructor for your +class. Instead, you should use a C<BUILD()> method, which will be +called from the inlined constructor. + +Alternately, if you really need to provide a different C<new()>, you +can also provide your own immutabilization method. Doing so requires +extending the Moose metaclasses, and is well beyond the scope of this +manual. + +=head1 INSTANTIATING CLASSES + +When you're ready to use Moose classes in an application, reference them in +your code in the regular Perl OO way by including a C<use> directive +at the top of the file where the objects should be created. + + use Person; + + my $person = Person->new( + # attribute values at instantiation + # go here + ssn => '123456789', + ); + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Concepts.pod b/lib/Moose/Manual/Concepts.pod new file mode 100644 index 0000000..d6211ef --- /dev/null +++ b/lib/Moose/Manual/Concepts.pod @@ -0,0 +1,439 @@ +# PODNAME: Moose::Manual::Concepts +# ABSTRACT: Moose OO concepts + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Concepts - Moose OO concepts + +=head1 VERSION + +version 2.1405 + +=head1 MOOSE CONCEPTS (VS "OLD SCHOOL" Perl) + +In the past, you may not have thought too much about the difference +between packages and classes, attributes and methods, constructors and +methods, etc. With Moose, these are all conceptually separate, +though under the hood they're implemented with plain old Perl. + +Our meta-object protocol (aka MOP) provides well-defined introspection +features for each of those concepts, and Moose in turn provides +distinct sugar for each of them. Moose also introduces additional +concepts such as 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 making your package a +class. At its simplest, a class will consist simply of attributes +and/or methods. It can also include roles, method modifiers, and more. + +A class I<has> zero or more B<attributes>. + +A class I<has> zero or more B<methods>. + +A class I<has> zero or more superclasses (aka parent classes). A +class inherits from its superclass(es). + +A class I<has> zero or more B<method modifiers>. These modifiers can +apply to its own methods or methods that are inherited from its +ancestors. + +A class I<does> (and I<consumes>) zero or more B<roles>. + +A class I<has> a B<constructor> and a B<destructor>. These are +provided for you "for free" by Moose. + +The B<constructor> accepts named parameters corresponding to the +class's attributes and uses them to initialize an B<object instance>. + +A class I<has> a B<metaclass>, which in turn has B<meta-attributes>, +B<meta-methods>, and B<meta-roles>. This metaclass I<describes> the +class. + +A class is usually analogous to a category of nouns, like "People" or +"Users". + + package Person; + + use Moose; + # now it's a Moose class! + +=head2 Attribute + +An attribute is a property of the class that defines it. It I<always> +has a name, and it I<may have> a number of other properties. + +These properties can 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 +have a reader accessor method. Many attributes have other +methods, such as a writer method, a clearer method, or a predicate method +("has it been set?"). + +An attribute may also define B<delegations>, which will create +additional methods based on the delegation mapping. + +By default, Moose stores attributes in the object instance, which is a +hashref, I<but this is invisible to the author of a Moose-based +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 something that the class's members have. 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 B<method> is very straightforward. Any subroutine you define in your +class is a method. + +B<Methods> correspond to verbs, and are what your objects can do. For +example, a User can login. + + sub login { ... } + +=head2 Role + +A role is something that a class I<does>. We also say that classes +I<consume> roles. For example, a Machine class might do the Breakable +role, and so could a Bone class. A role is used to define some concept +that cuts across multiple unrelated classes, like "breakability", or +"has a color". + +A role I<has> zero or more B<attributes>. + +A role I<has> zero or more B<methods>. + +A role I<has> zero or more B<method modifiers>. + +A role I<has> zero or more B<required methods>. + +A required method is not implemented by the role. Required methods are a way +for the role to declare "to use this role you must implement this method". + +A role I<has> zero or more B<excluded roles>. + +An excluded role is a role that the role doing the excluding says it +cannot be combined with. + +Roles are I<composed> into classes (or other roles). When a role is +composed into a class, its attributes and methods are "flattened" into +the class. Roles I<do not> show up in the inheritance hierarchy. When +a role is composed, its attributes and methods appear as if they were +defined I<in the consuming class>. + +Role are somewhat like mixins or interfaces in other OO languages. + + package Breakable; + + use Moose::Role; + + requires 'break'; + + has 'is_broken' => ( + is => 'rw', + isa => 'Bool', + ); + + after 'break' => sub { + my $self = shift; + + $self->is_broken(1); + }; + +=head2 Method modifiers + +A B<method modifier> is a hook that is called when a named method is +called. 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 the types +Perl provides in its core, such as C<Str>, C<Num>, C<Bool>, C<HashRef>, etc. + +In addition, every class name in your application can also be used as +a type name. + +Finally, you can define your own types with their own constraints. For +example, you could define a C<PosInt> type, a subtype of C<Int> which only +allows positive numbers. + +=head2 Delegation + +Moose attributes provide declarative syntax for defining delegations. A +delegation is a method which in turn calls some method on an attribute to do +its real work. + +=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. (Okay, it's usually a blessed hashref with Moose, too.) + +=head2 Moose vs old school summary + +=over 4 + +=item * Class + +A package with no introspection other than mucking about in the symbol +table. + +With Moose, you get well-defined declaration and introspection. + +=item * Attributes + +Hand-written accessor methods, symbol table hackery, or a helper +module like C<Class::Accessor>. + +With Moose, these are declaratively defined, and distinct from +methods. + +=item * Method + +These are pretty much the same in Moose as in old school Perl. + +=item * Roles + +C<Class::Trait> or C<Class::Role>, or maybe C<mixin.pm>. + +With Moose, they're part of the core feature set, and are +introspectable like everything else. + +=item * Method Modifiers + +Could only be done through serious symbol table wizardry, and you +probably never saw this before (at least in Perl 5). + +=item * Type + +Hand-written parameter checking in your C<new()> method and accessors. + +With Moose, you define types declaratively, and then use them by name +with 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. The C<meta()> method 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->get_all_attributes ) { + print $attribute->name(), "\n"; + + if ( $attribute->has_type_constraint ) { + print " type: ", $attribute->type_constraint->name, "\n"; + } + } + + for my $method ( $meta->get_all_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 parameters 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 WHAT NEXT? + +So you're sold on Moose. Time to learn how to really use it. + +If you want to see how Moose would translate directly into old school +Perl 5 OO code, check out L<Moose::Manual::Unsweetened>. This might be +helpful for quickly wrapping your brain around some aspects of "the +Moose way". + +Or you can skip that and jump straight to L<Moose::Manual::Classes> +and the rest of the L<Moose::Manual>. + +After that 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 extend Moose itself. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Construction.pod b/lib/Moose/Manual/Construction.pod new file mode 100644 index 0000000..1e6c53f --- /dev/null +++ b/lib/Moose/Manual/Construction.pod @@ -0,0 +1,225 @@ +# PODNAME: Moose::Manual::Construction +# ABSTRACT: Object construction (and destruction) with Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Construction - Object construction (and destruction) with Moose + +=head1 VERSION + +version 2.1405 + +=head1 WHERE'S THE CONSTRUCTOR? + +B<Do not define a C<new()> method for your classes!> + +When you C<use Moose> in your class, your class becomes a subclass of +L<Moose::Object>. The L<Moose::Object> provides a C<new()> method for your +class. If you follow our recommendations in L<Moose::Manual::BestPractices> +and make your class immutable, then you actually get a class-specific C<new()> +method "inlined" in your class. + +=head1 OBJECT CONSTRUCTION AND ATTRIBUTES + +The Moose-provided constructor accepts a hash or hash reference of +named parameters matching your attributes (actually, matching their +C<init_arg>s). This is just another way in which Moose keeps you from +worrying I<how> classes are implemented. Simply define a class and +you're ready to start creating objects! + +=head1 OBJECT CONSTRUCTION HOOKS + +Moose lets you hook into object construction. You can validate an +object's state, do logging, customize construction from parameters which +do not match your attributes, or maybe allow non-hash(ref) constructor +arguments. You can do this by creating C<BUILD> and/or C<BUILDARGS> +methods. + +If these methods exist in your class, Moose will arrange for them to +be called as part of the object construction process. + +=head2 BUILDARGS + +The C<BUILDARGS> method is called as a class method I<before> an +object is created. It will receive all of the arguments that were +passed to C<new()> I<as-is>, and is expected to return a hash +reference. This hash reference will be used to construct the object, +so it should contain keys matching your attributes' names (well, +C<init_arg>s). + +One common use for C<BUILDARGS> is to accommodate a non-hash(ref) +calling style. For example, we might want to allow our Person class to +be called with a single argument of a social security number, C<< +Person->new($ssn) >>. + +Without a C<BUILDARGS> method, Moose will complain, because it expects +a hash or hash reference. We can use the C<BUILDARGS> method to +accommodate this calling style: + + around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + + if ( @_ == 1 && !ref $_[0] ) { + return $class->$orig( ssn => $_[0] ); + } + else { + return $class->$orig(@_); + } + }; + +Note the call to C<< $class->$orig >>. This will call the default C<BUILDARGS> +in L<Moose::Object>. This method takes care of distinguishing between a hash +reference and a plain hash for you. + +=head2 BUILD + +The C<BUILD> method is called I<after> an object is created. There are +several reasons to use a C<BUILD> method. One of the most common is to +check that the object state is valid. While we can validate individual +attributes through the use of types, we can't validate the state of a +whole object that way. + + sub BUILD { + my $self = shift; + + if ( $self->country_of_residence eq 'USA' ) { + die 'All US residents must have an SSN' + unless $self->has_ssn; + } + } + +Another use of a C<BUILD> method could be for logging or tracking +object creation. + + sub BUILD { + my $self = shift; + + debug( 'Made a new person - SSN = ', $self->ssn, ); + } + +The C<BUILD> method is called with the hash reference of the parameters passed +to the constructor (after munging by C<BUILDARGS>). This gives you a chance to +do something with parameters that do not represent object attributes. + + sub BUILD { + my $self = shift; + my $args = shift; + + $self->add_friend( + My::User->new( + user_id => $args->{user_id}, + ) + ); + } + +=head3 BUILD and parent classes + +The interaction between multiple C<BUILD> methods in an inheritance hierarchy +is different from normal Perl methods. B<You should never call C<< +$self->SUPER::BUILD >>>, nor should you ever apply a method modifier to +C<BUILD>. + +Moose arranges to have all of the C<BUILD> methods in a hierarchy +called when an object is constructed, I<from parents to +children>. This might be surprising at first, because it reverses the +normal order of method inheritance. + +The theory behind this is that C<BUILD> methods can only be used for +increasing specialization of a class's constraints, so it makes sense +to call the least specific C<BUILD> method first. Also, this is how +Perl 6 does it. + +=head1 OBJECT DESTRUCTION + +Moose provides a hook for object destruction with the C<DEMOLISH> +method. As with C<BUILD>, you should never explicitly call C<< +$self->SUPER::DEMOLISH >>. Moose will arrange for all of the +C<DEMOLISH> methods in your hierarchy to be called, from most to least +specific. + +Each C<DEMOLISH> method is called with a single argument. This is a boolean +value indicating whether or not this method was called as part of the global +destruction process (when the Perl interpreter exits). + +In most cases, Perl's built-in garbage collection is sufficient, and +you won't need to provide a C<DEMOLISH> method. + +=head2 Error Handling During Destruction + +The interaction of object destruction and Perl's global C<$@> and C<$?> +variables can be very confusing. + +Moose always localizes C<$?> when an object is being destroyed. This means +that if you explicitly call C<exit>, that exit code will be preserved even if +an object's destructor makes a system call. + +Moose also preserves C<$@> against any C<eval> calls that may happen during +object destruction. However, if an object's C<DEMOLISH> method actually dies, +Moose explicitly rethrows that error. + +If you do not like this behavior, you will have to provide your own C<DESTROY> +method and use that instead of the one provided by L<Moose::Object>. You can +do this to preserve C<$@> I<and> capture any errors from object destruction by +creating an error stack. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Contributing.pod b/lib/Moose/Manual/Contributing.pod new file mode 100644 index 0000000..2c3b239 --- /dev/null +++ b/lib/Moose/Manual/Contributing.pod @@ -0,0 +1,546 @@ +# PODNAME: Moose::Manual::Contributing +# ABSTRACT: How to get involved in Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Contributing - How to get involved in Moose + +=head1 VERSION + +version 2.1405 + +=head1 GETTING INVOLVED + +Moose is an open project, and we are always willing to accept bug fixes, +more tests, and documentation patches. Commit bits are given out freely and +it's easy to get started! + +=head2 Get the Code + +If you just want to get your feet wet and check out the code, you can do so +from the comfort of your web browser by going to the official repository on +GitHub: L<https://github.com/moose/Moose>. + +However, if you know how to use git and would rather have a local copy +(because, why wouldn't you?!), then you can clone it: + + git clone git@github.com:moose/Moose.git + +If, at some point, you think you'd like to contribute a patch, please see +L</Getting Started>. + +I<B<NOTE:> Your contribution is very important to us. If, for some reason, +you would prefer not to use Git/GitHub, come talk to us at #moose on +irc.perl.org and we can work something out.> + +=head2 People + +As Moose has matured, some structure has emerged in the process. + +=over + +=item Cabal - people who can release moose + +These people are the ones who have co-maint on Moose itself and can create a +release. They're listed under L<Moose/CABAL> in the Moose documentation. They +are responsible for reviewing branches, and are the only people who are +allowed to push to stable branches. + +Cabal members are listed in L<Moose> and can often be found on irc in the +L<irc://irc.perl.org/#moose-dev> channel. + +=item Contributors - people creating a topic or branch + +You! + +=back + +=head2 New Features + +Moose already has a fairly large feature set, and we are currently +B<not> looking to add any major new features to it. If you have an +idea for a new feature in Moose, you are encouraged to create a +MooseX module first. + +At this stage, no new features will even be considered for addition +into the core without first being vetted as a MooseX module, unless +it is absolutely 100% impossible to implement the feature outside the +core. + +If you think it is 100% impossible, please come discuss it with us on IRC or +via e-mail. Your feature may need a small hook in the core, or a +refactoring of some core modules, and we are definitely open to that. + +Moose was built from the ground up with the idea of being highly extensible, +and quite often the feature requests we see can be implemented through small +extensions. Try it, it's much easier than you might think. + +=head2 Branch Layout + +The repository is divided into several branches to make maintenance easier for +everyone involved. The branches below are ordered by level of stability. + +=over + +=item stable/* + +The branch from which releases are cut. When making a new major release, the +release manager makes a new C<stable/X.YY> branch at the current position of +C<master>. The version used in the stable branch should not include the last +two digits of the version number. + +For minor releases, patches will be committed to C<master>, and +backported (cherry-picked) to the appropriate stable branch as needed. A +stable branch is only updated by someone from the Cabal during a release. + +=item master + +The main development branch. All new code should be written against this +branch. This branch contains code that has been reviewed, and will be included +in the next major release. Commits which are judged to not break backwards +compatibility may be backported into C<stable> to be included in the next minor +release. + +=item topic/* + +Small personal branches that are still in progress. They can be freely rebased. +They contain targeted features that may span a handful of commits. Any change +or bugfix should be created in a topic branch. + +=item rfc/* + +Topic branches that are completed and waiting on review. A Cabal member will +look over branches in this namespace, and either merge them to C<master> if +they are acceptable, or move them back to a different namespace otherwise. +This namespace is being phased out now that we are using GitHub's pull +requests in our L</Development Workflow>. + +=item attic/* + +Branches which have been reviewed, and rejected. They remain in the repository +in case we later change our mind, or in case parts of them are still useful. + +=item abandoned/* + +Topic branches which have had no activity for a long period of time will be +moved here, to keep the main areas clean. + +=back + +Larger, longer term branches can also be created in the root namespace (i.e. +at the same level as master and stable). This may be appropriate if multiple +people are intending to work on the branch. These branches should not be +rebased without checking with other developers first. + +=head1 WORKFLOWS + +=head2 Getting Started + +So, you've cloned the main Moose repository to your local machine (see +L</Get the Code>) and you're ready to do some hacking. We couldn't be +happier to welcome you to our community! + +Of course, to ensure that your first experience is as productive and +satisfying as possible, you should probably take some time to read over this +entire POD document. Doing so will give you a full understanding of how Moose +developers and maintainers work together and what they expect from one +another. Done? Great! + +Next, assuming you have a GitHub account, go to +L<http://github.com/moose/Moose> and B<fork the repository> (see +L<https://help.github.com/articles/fork-a-repo>). This will put an exact +replica of the Moose repository into your GitHub account, which will serve as +a place to publish your patches for the Moose maintainers to review and +incorporate. + +Once your fork has been created, switch to your local working repository directory +and update your C<origin> remote's push URL. This allows you to use a single +remote (C<origin>) to both pull in the latest code from GitHub and also push +your work to your own fork: + + # Replace YOUR_USERNAME below with your GitHub username + git remote set-url --push origin git@github.com:YOUR_USERNAME/moose.git + +You can verify your work: + + $ git remote -v + origin git@github.com:moose/Moose.git (fetch) + origin git@github.com:YOUR_USERNAME/moose.git (push) + +Now, you're ready for action! From now on, you just follow the L</Development +Workflow> to publish your work and B<submit pull requests> to the Moose Cabal. + +=head2 Development Workflow + +The general gist of the B<STANDARD WORKFLOW> is: + +=over 4 + +=item 1. Update your local repository with the latest commits from the official repository + +=item 2. Create a new topic branch, based on the master branch + +=item 3. Hack away + +=item 4. Commit and push the topic branch to your forked repository + +=item 5. Submit a pull request through GitHub for that branch + +=back + +What follows is a more detailed rundown of that workflow. Please make sure to +review and follow the steps in the previous section, L</Getting Started>, if +you have not done so already. + +=head3 Update Your Repository + +Update your local copy of the master branch from the remote: + + git checkout master + git pull --rebase + +=head3 Create Your Topic Branch + +Now, create a new topic branch based on your master branch. It's useful to +use concise, descriptive branch names such as: pod-syntax-contrib, +feat-autodelegation, patch-23-role-comp, etc. However, we'll just call ours +C<my-feature> for demonstration purposes: + + git checkout -b topic/my-feature + +=head3 Hack. Commit. Repeat. + +While you're hacking, the most important thing to remember is that your topic +branch is yours to do with as you like. Nothing you do there will affect +anyone else at this point. Commit as often as little or as often as you need +to and don't let perfection get in the way of progress. However, don't try to +do too much as the easiest changes to integrate are small and focused. + +If it's been a while since you created your topic branch, it's often a good +idea to periodically rebase your branch off of the upstream master to reduce +your work later on: + + git fetch # or, git remote update + git rebase origin/master # or, git pull --rebase origin master + +You should also feel free to publish (using C<push --force> if necessary) your +branch to your GitHub fork if you simply need feedback from others. (Note: +actual collaboration takes a bit more finesse and a lot less C<--force> +however). + +=head3 Clean Up Your Branch + +Finally, when your development is done, it's time to prepare your branch for +review. Even the smallest branches can often use a little bit of tidying up +before they are unleashed on a reviewer. Clarifying/cleaning up commit +messages, reordering commits, splitting large commits or those which contain +different types of changes, squashing related or straggler commits are all +B<highly> worthwhile activities to undertake on your topic branch. + +B<Remember:> Your topic branch is yours. Don't worry about rewriting its +history or breaking fast-forward. Some useful commands are listed below but +please make sure that you understand what they do as they can rewrite history: + + - git commit --amend + - git rebase --interactive + - git cherry-pick + +Ultimately, your goal in cleaning up your branch is to craft a set of commits +whose content and messages are as focused and understandable as possible. +Doing so will greatly increase the chances of a speedy review and acceptance +into the mainline development. + +=head3 Rebase on the Latest + +Before your final push and issuing a pull request, you need to ensure that +your changes can be easily merged into the master branch of the upstream +repository. This is done by once again rebasing your branch on the latest +C<origin/master>. + + git fetch # or, git remote update + git rebase origin/master # or, git pull --rebase origin master + +=head3 Publish and Pull Request + +Now it's time to make your final push of the branch to your fork. The +C<--force> flag is only necessary if you've pushed before and subsequently +rewriting your history: + + git push --force + +After your branch is published, you can issue a pull request to the Moose +Cabal. See <https://help.github.com/articles/using-pull-requests> for details. + +Congratulations! You're now a contributor! + +=head2 Approval Workflow + +Moose is an open project but it is also an increasingly important one. Many +modules depend on Moose being stable. Therefore, we have a basic set of +criteria for reviewing and merging branches. What follows is a set of rough +guidelines that ensures all new code is properly vetted before it is merged to +the master branch. + +It should be noted that if you want your specific branch to be approved, it is +B<your> responsibility to follow this process and advocate for your branch. + +=over 4 + +=item Small bug fixes, doc patches and additional passing tests. + +These items don't really require approval beyond one of the core contributors +just doing a simple review. For especially simple patches (doc patches +especially), committing directly to master is fine. + +=item Larger bug fixes, doc additions and TODO or failing tests. + +Larger bug fixes should be reviewed by at least one cabal member and should be +tested using the F<xt/author/test-my-dependents.t> test. + +New documentation is always welcome, but should also be reviewed by a cabal +member for accuracy. + +TODO tests are basically feature requests, see our L</New Features> section +for more information on that. If your feature needs core support, create a +C<topic/> branch using the L</Development Workflow> and start hacking away. + +Failing tests are basically bug reports. You should find a core contributor +and/or cabal member to see if it is a real bug, then submit the bug and your +test to the RT queue. Source control is not a bug reporting tool. + +=item New user-facing features. + +Anything that creates a new user-visible feature needs to be approved by +B<more than one> cabal member. + +Make sure you have reviewed L</New Features> to be sure that you are following +the guidelines. Do not be surprised if a new feature is rejected for the core. + +=item New internals features. + +New features for Moose internals are less restrictive than user facing +features, but still require approval by B<at least one> cabal member. + +Ideally you will have run the F<test-my-dependents.t> script to be sure you +are not breaking any MooseX module or causing any other unforeseen havoc. If +you do this (rather than make us do it), it will only help to hasten your +branch's approval. + +=item Backwards incompatible changes. + +Anything that breaks backwards compatibility must be discussed by the +cabal. Backwards incompatible changes should not be merged to master if there +are strong objections from any cabal members. + +We have a policy for what we see as sane L</BACKWARDS COMPATIBILITY> for +Moose. If your changes break back-compat, you must be ready to discuss and +defend your change. + +=back + +=head2 Release Workflow + + # major releases (including trial releases) + git checkout master + + # minor releases + git checkout stable/X.YY + + # do final changelogging, etc + vim dist.ini # increment version number + git commit + dzil release # or dzil release --trial for trial releases + git commit # to add the actual release date + git branch stable/X.YY # only for non-trial major releases + +=head3 Release How-To + +Moose uses L<Dist::Zilla> to manage releases. Although the git repository comes +with a C<Makefile.PL>, it is a very basic one just to allow the basic +C<perl Makefile.PL && make && make test> cycle to work. In particular, it +doesn't include any release metadata, such as dependencies. In order to get +started with Dist::Zilla, first install it: C<cpanm Dist::Zilla>, and then +install the plugins necessary for reading the C<dist.ini>: +C<dzil authordeps | cpanm>. + +Moose releases fall into two categories, each with their own level of release +preparation. A minor release is one which does not include any API changes, +deprecations, and so on. In that case, it is sufficient to simply test the +release candidate against a few different Perls. Testing should be done against +at least two recent major versions of Perl (5.8.8 and 5.10.1, for example). If +you have more versions available, you are encouraged to test them all. However, +we do not put a lot of effort into supporting older 5.8.x releases. + +For major releases which include an API change or deprecation, you should run +the F<xt/author/test-my-dependents.t> test. This tests a long list of MooseX +and other Moose-using modules from CPAN. In order to run this script, you must +arrange to have the new version of Moose in Perl's include path. You can use +C<prove -b> and C<prove -I>, install the module, or fiddle with the C<PERL5LIB> +environment variable, whatever makes you happy. + +This test downloads each module from CPAN, runs its tests, and logs failures +and warnings to a set of files named F<test-mydeps-$$-*.log>. If there are +failures or warnings, please work with the authors of the modules in question +to fix them. If the module author simply isn't available or does not want to +fix the bug, it is okay to make a release. + +Regardless of whether or not a new module is available, any breakages should +be noted in the conflicts list in the distribution's F<dist.ini>. + +=head2 Emergency Bug Workflow (for immediate release) + +The stable branch exists for easily making bug fix releases. + + git remote update + git checkout -b topic/my-emergency-fix origin/master + # hack + git commit + +Then a cabal member merges into C<master>, and backports the change into +C<stable/X.YY>: + + git checkout master + git merge topic/my-emergency-fix + git push + git checkout stable/X.YY + git cherry-pick -x master + git push + # release + +=head2 Project Workflow + +For longer lasting branches, we use a subversion style branch layout, where +master is routinely merged into the branch. Rebasing is allowed as long as all +the branch contributors are using C<git pull --rebase> properly. + +C<commit --amend>, C<rebase --interactive>, etc. are not allowed, and should +only be done in topic branches. Committing to master is still done with the +same review process as a topic branch, and the branch must merge as a fast +forward. + +This is pretty much the way we're doing branches for large-ish things right +now. + +Obviously there is no technical limitation on the number of branches. You can +freely create topic branches off of project branches, or sub projects inside +larger projects freely. Such branches should incorporate the name of the branch +they were made off so that people don't accidentally assume they should be +merged into master: + + git checkout -b my-project--topic/foo my-project + +(unfortunately Git will not allow C<my-project/foo> as a branch name if +C<my-project> is a valid ref). + +=head1 BRANCH ARCHIVAL + +Merged branches should be deleted. + +Failed branches may be kept, but should be moved to C<attic/> to differentiate +them from in-progress topic branches. + +Branches that have not been worked on for a long time will be moved to +C<abandoned/> periodically, but feel free to move the branch back to C<topic/> +if you want to start working on it again. + +=head1 TESTS, TESTS, TESTS + +If you write I<any> code for Moose, you B<must> add tests for that code. If you +do not write tests then we cannot guarantee your change will not be removed or +altered at a later date, as there is nothing to confirm this is desired +behavior. + +If your code change/addition is deep within the bowels of Moose and your test +exercises this feature in a non-obvious way, please add some comments either +near the code in question or in the test so that others know. + +We also greatly appreciate documentation to go with your changes, and an entry +in the Changes file. Make sure to give yourself credit! Major changes or new +user-facing features should also be documented in L<Moose::Manual::Delta>. + +=head1 DOCS, DOCS, DOCS + +Any user-facing changes must be accompanied by documentation. If you're not +comfortable writing docs yourself, you might be able to convince another Moose +dev to help you. + +Our goal is to make sure that all features are documented. Undocumented +features are not considered part of the API when it comes to determining +whether a change is backwards compatible. + +=head1 BACKWARDS COMPATIBILITY + +Change is inevitable, and Moose is not immune to this. We do our best +to maintain backwards compatibility, but we do not want the code base +to become overburdened by this. This is not to say that we will be +frivolous with our changes, quite the opposite, just that we are not +afraid of change and will do our best to keep it as painless as +possible for the end user. + +Our policy for handling backwards compatibility is documented in more detail in +L<Moose::Manual::Support>. + +All backwards incompatible changes B<must> be documented in +L<Moose::Manual::Delta>. Make sure to document any useful tips or workarounds +for the change in that document. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Delegation.pod b/lib/Moose/Manual/Delegation.pod new file mode 100644 index 0000000..0d6210d --- /dev/null +++ b/lib/Moose/Manual/Delegation.pod @@ -0,0 +1,313 @@ +# PODNAME: Moose::Manual::Delegation +# ABSTRACT: Attribute delegation + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Delegation - Attribute delegation + +=head1 VERSION + +version 2.1405 + +=head1 WHAT IS DELEGATION? + +Delegation is a feature that lets you create "proxy" methods that do nothing +more than call some other method on an attribute. This lets you simplify a +complex set of "has-a" relationships and present a single unified API from one +class. + +With delegation, consumers of a class don't need to know about all the +objects it contains, reducing the amount of API they need to learn. + +Delegations are defined as a mapping between one or more methods +provided by the "real" class (the delegatee), and a set of +corresponding methods in the delegating class. The delegating class +can re-use the method names provided by the delegatee or provide its +own names. + +Delegation is also a great way to wrap an existing class, especially a +non-Moose class or one that is somehow hard (or impossible) to +subclass. + +=head1 DEFINING A MAPPING + +Moose offers a number of options for defining a delegation's mapping, +ranging from simple to complex. + +The simplest form is to simply specify a list of methods: + + package Website; + + use Moose; + + has 'uri' => ( + is => 'ro', + isa => 'URI', + handles => [qw( host path )], + ); + +Using an arrayref tells Moose to create methods in your class that match the +method names in the delegated class. + +With this definition, we can call C<< $website->host >> and it "just +works". Under the hood, Moose will call C<< $website->uri->host >> for +you. Note that C<$website> is I<not> automatically passed to the C<host> +method; the invocant is C<< $website->uri >>. + +We can also define a mapping as a hash reference. This allows you to +rename methods as part of the mapping: + + package Website; + + use Moose; + + has 'uri' => ( + is => 'ro', + isa => 'URI', + handles => { + hostname => 'host', + path => 'path', + }, + ); + +Using a hash tells Moose to create method names (specified on the left) which +invoke the delegated class methods (specified on the right). + +In this example, we've created a C<< $website->hostname >> method, +rather than simply using C<URI.pm>'s name, C<host> in the Website +class. + +These two mapping forms are the ones you will use most often. The +remaining methods are a bit more complex. + + has 'uri' => ( + is => 'ro', + isa => 'URI', + handles => qr/^(?:host|path|query.*)/, + ); + +This is similar to the array version, except it uses the regex to +match against all the methods provided by the delegatee. In order for +this to work, you must provide an C<isa> parameter for the attribute, +and it must be a class. Moose uses this to introspect the delegatee +class and determine what methods it provides. + +You can use a role name as the value of C<handles>: + + has 'uri' => ( + is => 'ro', + isa => 'URI', + handles => 'HasURI', + ); + +Moose will introspect the role to determine what methods it provides +and create a name-for-name mapping for each of those methods. + +Finally, you can provide a sub reference to I<generate> a mapping that behaves +like the hash example above. You probably won't need this version often (if +ever). See the L<Moose> docs for more details on exactly how this works. + +=head1 NATIVE DELEGATION + +Native delegations allow you to delegate to standard Perl data structures as +if they were objects. + + has 'queue' => ( + traits => ['Array'], + isa => 'ArrayRef[Item]', + default => sub { [ ] }, + handles => { + add_item => 'push', + next_item => 'shift', + }, + ) + +The C<Array> trait in the C<traits> parameter tells Moose that you would like +to use the set of Array helpers. Moose will then create C<add_item> and +C<next_item> methods that "just work". Behind the scenes C<add_item> is +something like + + sub add_item { + my ($self, @items) = @_; + + for my $item (@items) { + $Item_TC->validate($item); + } + + push @{ $self->queue }, @items; + } + +For example, you might use Array helpers to add C<add_task> and +C<add_appointment> methods to a Calendar class: + + has 'tasks' => ( + traits => ['Array'], + isa => 'ArrayRef[Task]', + default => sub { [ ] }, + handles => { + add_task => 'push', + next_task => 'shift', + }, + ); + + has 'appointments' => ( + traits => ['Array'], + isa => 'ArrayRef[Appointment]', + default => sub { [ ] }, + handles => { + add_appointment => 'push', + next_appointment => 'shift', + }, + ); + +Which you would call as: + + $calendar->add_task( $task_obj ); + $calendar->add_appointment( $appointment_obj ); + +As mentioned above, each trait provides a number of methods which are +summarized below. For more information about each of these provided methods +see the documentation for that specific trait. + +Moose includes the following traits for native delegation. + +=over 4 + +=item * L<Array|Moose::Meta::Attribute::Native::Trait::Array> + +The following methods are provided by the native Array trait: + +count, is_empty, elements, get, pop, push, shift, unshift, splice, first, +first_index, grep, map, reduce, sort, sort_in_place, shuffle, uniq, join, set, +delete, insert, clear, accessor, natatime, shallow_clone + +=item * L<Bool|Moose::Meta::Attribute::Native::Trait::Bool> + +The following methods are provided by the native Bool trait: + +set, unset, toggle, not + +=item * L<Code|Moose::Meta::Attribute::Native::Trait::Code> + +The following methods are provided by the native Code trait: + +execute, execute_method + +=item * L<Counter|Moose::Meta::Attribute::Native::Trait::Counter> + +The following methods are provided by the native Counter trait: + +set, inc, dec, reset + +=item * L<Hash|Moose::Meta::Attribute::Native::Trait::Hash> + +The following methods are provided by the native Hash trait: + +get, set, delete, keys, exists, defined, values, kv, elements, clear, count, +is_empty, accessor, shallow_clone + +=item * L<Number|Moose::Meta::Attribute::Native::Trait::Number> + +The following methods are provided by the native Number trait: + +add, sub, mul, div, mod, abs + +=item * L<String|Moose::Meta::Attribute::Native::Trait::String> + +The following methods are provided by the native String trait: + +inc, append, prepend, replace, match, chop, chomp, clear, length, substr + +=back + +=head1 CURRYING + +Currying allows you to create a method with some pre-set parameters. You can +create a curried delegation method: + + package Spider; + use Moose; + + has request => ( + is => 'ro' + isa => 'HTTP::Request', + handles => { + set_user_agent => [ header => 'UserAgent' ], + }, + ) + +With this definition, calling C<< $spider->set_user_agent('MyClient') >> will +call C<< $spider->request->header('UserAgent', 'MyClient') >> behind the +scenes. + +Note that with currying, the currying always starts with the first parameter to +a method (C<$_[0]>). Any arguments you pass to the delegation come after the +curried arguments. + +=head1 MISSING ATTRIBUTES + +It is perfectly valid to delegate methods to an attribute which is not +required or can be undefined. When a delegated method is called, Moose +will throw a runtime error if the attribute does not contain an +object. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Delta.pod b/lib/Moose/Manual/Delta.pod new file mode 100644 index 0000000..34edf17 --- /dev/null +++ b/lib/Moose/Manual/Delta.pod @@ -0,0 +1,1275 @@ +# PODNAME: Moose::Manual::Delta +# ABSTRACT: Important Changes in Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Delta - Important Changes in Moose + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This documents any important or noteworthy changes in Moose, with a +focus on things that affect backwards compatibility. This does duplicate data +from the F<Changes> file, but aims to provide more details and when possible +workarounds. + +Besides helping keep up with changes, you can also use this document +for finding the lowest version of Moose that supported a given +feature. If you encounter a problem and have a solution but don't see +it documented here, or think we missed an important feature, please +send us a patch. + +=head1 2.1400 + +=over 4 + +=item Overloading implementation has changed + +Overloading meta information used to be implemented by a +C<Class::MOP::Method::Overload> class. This class has been removed, and +overloading is now implemented by L<Class::MOP::Overload>. Overloading is not +really equivalent to a method, so the former implementation didn't work +properly for various cases. + +All of the overloading-related methods for classes and roles have the same +names, but those methods now return L<Class::MOP::Overload> objects. + +=item Core support for overloading in roles + +Roles which use overloading now pass that overloading onto other classes (and +roles) which consume that role. + +This works much like L<MooseX::Role::WithOverloading>, except that we properly +detect overloading conflicts during role summation and when applying one role +to another. L<MooseX::Role::WithOverloading> did not do any conflict +detection. + +If you want to write code that uses overloading and works with previous +versions of Moose and this one, upgrade to L<MooseX::Role::WithOverloading> +version 0.15 or greater. That version will detect when Moose itself handles +overloading and get out of the way. + +=back + +=head1 2.1200 + +=over 4 + +=item Classes created by Moose are now registered in C<%INC> + +This means that this will no longer die (and will also no longer try to load +C<Foo.pm>): + + { + package Foo; + use Moose; + } + + # ... + + use Foo; + +If you're using the MOP, this behavior will occur when the C<create> (or +C<create_anon_class>) method is used, but not when the C<initialize> method +is used. + +=item Moose now uses L<Module::Runtime> instead of L<Class::Load> to load classes + +Class::Load has always had some weird issues with the ways that it tries to +figure out if a class is loaded. For instance, extending an empty package was +previously impossible, because Class::Load would think that the class failed to +load, even though that is a perfectly valid thing to do. It was also difficult +to deal with modules like L<IO::Handle>, which partially populate several other +packages when they are loaded (so calling C<load_class> on C<'IO::Handle'> +followed by C<'IO::File'> could end up with a broken C<IO::File>, in some +cases). + +Now, Moose uses the same mechanisms as perl itself to figure out if a class is +loaded. A class is considered to be loaded if its entry in C<%INC> is set. Perl +sets the C<%INC> entry for you automatically whenever a file is loaded via +C<use> or C<require>. Also, as mentioned above, Moose also now sets the C<%INC> +entry for any classes defined with it, even if they aren't loaded from a +separate file. This does however mean that if you are trying to use Moose with +non-Moose classes defined in the same file, then you will need to set C<%INC> +manually now, where it may have worked in the past. For instance: + + { + package My::NonMoose; + + sub new { bless {}, shift } + + $INC{'My/NonMoose.pm'} = __FILE__; + # alternatively: + # use Module::Runtime 'module_notional_filename'; + # $INC{module_notional_filename(__PACKAGE__)} = __FILE__; + } + + { + package My::Moose; + use Moose; + + extends 'My::NonMoose'; + } + +If you don't do this, you will get an error message about not being able to +locate C<My::NonMoose> in C<@INC>. We hope that this case will be fairly rare. + +=item The Class::Load wrapper functions in Class::MOP have been deprecated + +C<Class::MOP::load_class>, C<Class::MOP::is_class_loaded>, and +C<Class::MOP::load_first_existing_class> have been deprecated. They have been +undocumented and discouraged since version 2.0200. You should replace their use +with the corresponding functions in L<Class::Load>, or just use +L<Module::Runtime> directly. + +=item The non-arrayref forms of C<enum> and C<duck_type> have been deprecated + +Originally, C<enum> could be called like this: + + enum('MyType' => qw(foo bar baz)) + +This was confusing, however (since it was different from the syntax for +anonymous enum types), and it makes error checking more difficult (since you +can't tell just by looking whether C<enum('Foo', 'Bar', 'Baz')> was intended to +be a type named C<Foo> with elements of C<Bar> and C<Baz>, or if this was +actually a mistake where someone got the syntax for an anonymous enum type +wrong). This all also applies to C<duck_type>. + +Calling C<enum> and C<duck_type> with a list of arguments as described above +has been undocumented since version 0.93, and is now deprecated. You should +replace + + enum MyType => qw(foo bar baz); + +in your code with + + enum MyType => [qw(foo bar baz)]; + +=item Moose string exceptions have been replaced by Moose exception objects + +Previously, Moose threw string exceptions on error conditions, which were not +so verbose. All those string exceptions have now been converted to exception +objects, which provide very detailed information about the exceptions. These +exception objects provide a string overload that matches the previous exception +message, so in most cases you should not have to change your code. + +For learning about the usage of Moose exception objects, read +L<Moose::Manual::Exceptions>. Individual exceptions are documented in +L<Moose::Manual::Exceptions::Manifest>. + +This work was funded as part of the GNOME Outreach Program for Women. + +=back + +=head1 2.1000 + +=over 4 + +=item The Num type is now stricter + +The C<Num> type used to accept anything that fits Perl's notion of a number, +which included Inf, NaN, and strings like C<" 1234 \n">. We believe that the +type constraint should indicate "this is a number", not "this coerces to a +number". Therefore, Num now only accepts integers, floating point numbers +(both in decimal notation and exponential notation), 0, .0, 0.0, etc. + +If you want the old behavior you can use the C<LaxNum> type in +L<MooseX::Types::LaxNum>. + +=item You can use L<Specio> instead of core Moose types + +The L<Specio> distribution is an experimental new type system intended to +eventually replace the core Moose types, but yet also work with things like +L<Moo> and L<Mouse> and anything else. Right now this is all speculative, but +at least you can use Specio with Moose. + +=back + +=head1 2.0600 + +=over 4 + +=item C<< ->init_meta >> is even less reliable at loading extensions + +Previously, calling C<< MooseX::Foo->init_meta(@_) >> (and nothing else) from +within your own C<init_meta> had a decent chance of doing something useful. +This was never supported behavior, and didn't always work anyway. Due to some +implementation adjustments, this now has a smaller chance of doing something +useful, which could break code that was expecting it to continue doing useful +things. Code that does this should instead just call +C<< MooseX::Foo->import({ into => $into }) >>. + +=item All the Cookbook recipes have been renamed + +We've given them all descriptive names, rather than numbers. This makes it +easier to talk about them, and eliminates the need to renumber recipes in +order to reorder them or delete one. + +=back + +=head1 2.0400 + +=over 4 + +=item The parent of a union type is its components' nearest common ancestor + +Previously, union types considered all of their component types their parent +types. This was incorrect because parent types are defined as types that must +be satisfied in order for the child type to be satisfied, but in a union, +validating as any parent type will validate against the entire union. This has +been changed to find the nearest common ancestor for all of its components. For +example, a union of "Int|ArrayRef[Int]" now has a parent of "Defined". + +=item Union types consider all members in the C<is_subtype_of> and C<is_a_type_of> methods + +Previously, a union type would report itself as being of a subtype of a type if +I<any> of its member types were subtypes of that type. This was incorrect +because any value that passes a subtype constraint must also pass a parent +constraint. This has changed so that I<all> of its member types must be a +subtype of the specified type. + +=item Enum types now work with just one value + +Previously, an C<enum> type needed to have two or more values. Nobody knew +why, so we fixed it. + +=item Methods defined in UNIVERSAL now appear in the MOP + +Any method introspection methods that look at methods from parent classes now +find methods defined in UNIVERSAL. This includes methods like C<< +$class->get_all_methods >> and C<< $class->find_method_by_name >>. + +This also means that you can now apply method modifiers to these methods. + +=item Hand-optimized type constraint code causes a deprecation warning + +If you provide an optimized sub ref for a type constraint, this now causes a +deprecation warning. Typically, this comes from passing an C<optimize_as> +parameter to C<subtype>, but it could also happen if you create a +L<Moose::Meta::TypeConstraint> object directly. + +Use the inlining feature (C<inline_as>) added in 2.0100 instead. + +=item C<Class::Load::load_class> and C<is_class_loaded> have been removed + +The C<Class::MOP::load_class> and C<Class::MOP::is_class_loaded> subroutines +are no longer documented, and will cause a deprecation warning in the +future. Moose now uses L<Class::Load> to provide this functionality, and you +should do so as well. + +=back + +=head1 2.0205 + +=over 4 + +=item Array and Hash native traits provide a C<shallow_clone> method + +The Array and Hash native traits now provide a "shallow_clone" method, which +will return a reference to a new container with the same contents as the +attribute's reference. + +=back + +=head1 2.0200 + +=over 4 + +=item Hand-optimized type constraint code is deprecated in favor of inlining + +Moose allows you to provide a hand-optimized version of a type constraint's +subroutine reference. This version allows type constraints to generate inline +code, and you should use this inlining instead of providing a hand-optimized +subroutine reference. + +This affects the C<optimize_as> sub exported by +L<Moose::Util::TypeConstraints>. Use C<inline_as> instead. + +This will start warning in the 2.0300 release. + +=back + +=head1 2.0002 + +=over 4 + +=item More useful type constraint error messages + +If you have L<Devel::PartialDump> version 0.14 or higher installed, Moose's +type constraint error messages will use it to display the invalid value, rather +than just displaying it directly. This will generally be much more useful. For +instance, instead of this: + + Attribute (foo) does not pass the type constraint because: Validation failed for 'ArrayRef[Int]' with value ARRAY(0x275eed8) + +the error message will instead look like + + Attribute (foo) does not pass the type constraint because: Validation failed for 'ArrayRef[Int]' with value [ "a" ] + +Note that L<Devel::PartialDump> can't be made a direct dependency at the +moment, because it uses Moose itself, but we're considering options to make +this easier. + +=back + +=head1 2.0000 + +=over 4 + +=item Roles have their own default attribute metaclass + +Previously, when a role was applied to a class, it would use the attribute +metaclass defined in the class when copying over the attributes in the role. +This was wrong, because for instance, using L<MooseX::FollowPBP> in the class +would end up renaming all of the accessors generated by the role, some of which +may be being called in the role, causing it to break. Roles now keep track of +their own attribute metaclass to use by default when being applied to a class +(defaulting to Moose::Meta::Attribute). This is modifiable using +L<Moose::Util::MetaRole> by passing the C<applied_attribute> key to the +C<role_metaroles> option, as in: + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['My::Meta::Role::Attribute'], + }, + role_metaroles => { + applied_attribute => ['My::Meta::Role::Attribute'], + }, + ); + +=item Class::MOP has been folded into the Moose dist + +Moose and Class::MOP are tightly related enough that they have always had to be +kept pretty closely in step in terms of versions. Making them into a single +dist should simplify the upgrade process for users, as it should no longer be +possible to upgrade one without the other and potentially cause issues. No +functionality has changed, and this should be entirely transparent. + +=item Moose's conflict checking is more robust and useful + +There are two parts to this. The most useful one right now is that Moose will +ship with a C<moose-outdated> script, which can be run at any point to list the +modules which are installed that conflict with the installed version of Moose. +After upgrading Moose, running C<moose-outdated | cpanm> should be sufficient +to ensure that all of the Moose extensions you use will continue to work. + +The other part is that Moose's C<META.json> file will also specify the +conflicts under the C<x_conflicts> (now C<x_breaks>) key. We are working with the Perl tool chain +developers to try to get conflicts support added to CPAN clients, and if/when +that happens, the metadata already exists, and so the conflict checking will +become automatic. + +=item The lazy_build attribute feature is discouraged + +While not deprecated, we strongly discourage you from using this feature. + +=item Most deprecated APIs/features are slated for removal in Moose 2.0200 + +Most of the deprecated APIs and features in Moose will start throwing an error +in Moose 2.0200. Some of the features will go away entirely, and some will +simply throw an error. + +The things on the chopping block are: + +=over 8 + +=item * Old public methods in Class::MOP and Moose + +This includes things like C<< Class::MOP::Class->get_attribute_map >>, C<< +Class::MOP::Class->construct_instance >>, and many others. These were +deprecated in L<Class::MOP> 0.80_01, released on April 5, 2009. + +These methods will be removed entirely in Moose 2.0200. + +=item * Old public functions in Class::MOP + +This include C<Class::MOP::subname>, C<Class::MOP::in_global_destruction>, and +the C<Class::MOP::HAS_ISAREV> constant. The first two were deprecated in 0.84, +and the last in 0.80. Class::MOP 0.84 was released on May 12, 2009. + +These functions will be removed entirely in Moose 2.0200. + +=item * The C<alias> and C<excludes> option for role composition + +These were renamed to C<-alias> and C<-excludes> in Moose 0.89, released on +August 13, 2009. + +Passing these will throw an error in Moose 2.0200. + +=item * The old L<Moose::Util::MetaRole> API + +This include the C<apply_metaclass_roles()> function, as well as passing the +C<for_class> or any key ending in C<_roles> to C<apply_metaroles()>. This was +deprecated in Moose 0.93_01, released on January 4, 2010. + +These will all throw an error in Moose 2.0200. + +=item * Passing plain lists to C<type()> or C<subtype()> + +The old API for these functions allowed you to pass a plain list of parameter, +rather than a list of hash references (which is what C<as()>, C<where>, +etc. return). This was deprecated in Moose 0.71_01, released on February 22, +2009. + +This will throw an error in Moose 2.0200. + +=item * The Role subtype + +This subtype was deprecated in Moose 0.84, released on June 26, 2009. + +This will be removed entirely in Moose 2.0200. + +=back + +=back + +=head1 1.21 + +=over 4 + +=item * New release policy + +As of the 2.0 release, Moose now has an official release and support policy, +documented in L<Moose::Manual::Support>. All API changes will now go through a +deprecation cycle of at least one year, after which the deprecated API can be +removed. Deprecations and removals will only happen in major releases. + +In between major releases, we will still make minor releases to add new +features, fix bugs, update documentation, etc. + +=back + +=head1 1.16 + +=over 4 + +=item Configurable stacktraces + +Classes which use the L<Moose::Error::Default> error class can now have +stacktraces disabled by setting the C<MOOSE_ERROR_STYLE> env var to C<croak>. +This is experimental, fairly incomplete, and won't work in all cases (because +Moose's error system in general is all of these things), but this should allow +for reducing at least some of the verbosity in most cases. + +=back + +=head1 1.15 + +=over 4 + +=item Native Delegations + +In previous versions of Moose, the Native delegations were created as +closures. The generated code was often quite slow compared to doing the same +thing by hand. For example, the Array's push delegation ended up doing +something like this: + + push @{ $self->$reader() }, @_; + +If the attribute was created without a reader, the C<$reader> sub reference +followed a very slow code path. Even with a reader, this is still slower than +it needs to be. + +Native delegations are now generated as inline code, just like other +accessors, so we can access the slot directly. + +In addition, native traits now do proper constraint checking in all cases. In +particular, constraint checking has been improved for array and hash +references. Previously, only the I<contained> type (the C<Str> in +C<HashRef[Str]>) would be checked when a new value was added to the +collection. However, if there was a constraint that applied to the whole +value, this was never checked. + +In addition, coercions are now called on the whole value. + +The delegation methods now do more argument checking. All of the methods check +that a valid number of arguments were passed to the method. In addition, the +delegation methods check that the arguments are sane (array indexes, hash +keys, numbers, etc.) when applicable. We have tried to emulate the behavior of +Perl builtins as much as possible. + +Finally, triggers are called whenever the value of the attribute is changed by +a Native delegation. + +These changes are only likely to break code in a few cases. + +The inlining code may or may not preserve the original reference when changes +are made. In some cases, methods which change the value may replace it +entirely. This will break tied values. + +If you have a typed arrayref or hashref attribute where the type enforces a +constraint on the whole collection, this constraint will now be checked. It's +possible that code which previously ran without errors will now cause the +constraint to fail. However, presumably this is a good thing ;) + +If you are passing invalid arguments to a delegation which were previously +being ignored, these calls will now fail. + +If your code relied on the trigger only being called for a regular writer, +that may cause problems. + +As always, you are encouraged to test before deploying the latest version of +Moose to production. + +=item Defaults is and default for String, Counter, and Bool + +A few native traits (String, Counter, Bool) provide default values of "is" and +"default" when you created an attribute. Allowing them to provide these values +is now deprecated. Supply the value yourself when creating the attribute. + +=item The C<meta> method + +Moose and Class::MOP have been cleaned up internally enough to make the +C<meta> method that you get by default optional. C<use Moose> and +C<use Moose::Role> now can take an additional C<-meta_name> option, which +tells Moose what name to use when installing the C<meta> method. Passing +C<undef> to this option suppresses generation of the C<meta> method +entirely. This should be useful for users of modules which also use a C<meta> +method or function, such as L<Curses> or L<Rose::DB::Object>. + +=back + +=head1 1.09 + +=over 4 + +=item All deprecated features now warn + +Previously, deprecation mostly consisted of simply saying "X is deprecated" in +the Changes file. We were not very consistent about actually warning. Now, all +deprecated features still present in Moose actually give a warning. The +warning is issued once per calling package. See L<Moose::Deprecated> for more +details. + +=item You cannot pass C<< coerce => 1 >> unless the attribute's type constraint has a coercion + +Previously, this was accepted, and it sort of worked, except that if you +attempted to set the attribute after the object was created, you would get a +runtime error. + +Now you will get a warning when you attempt to define the attribute. + +=item C<no Moose>, C<no Moose::Role>, and C<no Moose::Exporter> no longer unimport strict and warnings + +This change was made in 1.05, and has now been reverted. We don't know if the +user has explicitly loaded strict or warnings on their own, and unimporting +them is just broken in that case. + +=item Reversed logic when defining which options can be changed + +L<Moose::Meta::Attribute> now allows all options to be changed in an +overridden attribute. The previous behaviour required each option to be +whitelisted using the C<legal_options_for_inheritance> method. This method has +been removed, and there is a new method, C<illegal_options_for_inheritance>, +which can now be used to prevent certain options from being changeable. + +In addition, we only throw an error if the illegal option is actually +changed. If the superclass didn't specify this option at all when defining the +attribute, the subclass version can still add it as an option. + +Example of overriding this in an attribute trait: + + package Bar::Meta::Attribute; + use Moose::Role; + + has 'my_illegal_option' => ( + isa => 'CodeRef', + is => 'rw', + ); + + around illegal_options_for_inheritance => sub { + return ( shift->(@_), qw/my_illegal_option/ ); + }; + +=back + +=head1 1.05 + +=over 4 + +=item L<Moose::Object/BUILD> methods are now called when calling C<new_object> + +Previously, C<BUILD> methods would only be called from C<Moose::Object::new>, +but now they are also called when constructing an object via +C<Moose::Meta::Class::new_object>. C<BUILD> methods are an inherent part of the +object construction process, and this should make C<< $meta->new_object >> +actually usable without forcing people to use C<< $meta->name->new >>. + +=item C<no Moose>, C<no Moose::Role>, and C<no Moose::Exporter> now unimport strict and warnings + +In the interest of having C<no Moose> clean up everything that C<use Moose> +does in the calling scope, C<no Moose> (as well as all other +L<Moose::Exporter>-using modules) now unimports strict and warnings. + +=item Metaclass compatibility checking and fixing should be much more robust + +The L<metaclass compatibility|Moose/METACLASS COMPATIBILITY AND MOOSE> checking +and fixing algorithms have been completely rewritten, in both Class::MOP and +Moose. This should resolve many confusing errors when dealing with non-Moose +inheritance and with custom metaclasses for things like attributes, +constructors, etc. For correct code, the only thing that should require a +change is that custom error metaclasses must now inherit from +L<Moose::Error::Default>. + +=back + +=head1 1.02 + +=over 4 + +=item Moose::Meta::TypeConstraint::Class is_subtype_of behavior + +Earlier versions of L<is_subtype_of|Moose::Meta::TypeConstraint::Class/is_subtype_of> +would incorrectly return true when called with itself, its own TC name or +its class name as an argument. (i.e. $foo_tc->is_subtype_of('Foo') == 1) This +behavior was a caused by C<isa> being checked before the class name. The old +behavior can be accessed with L<is_type_of|Moose::Meta::TypeConstraint::Class/is_type_of> + +=back + +=head1 1.00 + +=over 4 + +=item Moose::Meta::Attribute::Native::Trait::Code no longer creates reader methods by default + +Earlier versions of L<Moose::Meta::Attribute::Native::Trait::Code> created +read-only accessors for the attributes it's been applied to, even if you didn't +ask for it with C<< is => 'ro' >>. This incorrect behaviour has now been fixed. + +=back + +=head1 0.95 + +=over 4 + +=item Moose::Util add_method_modifier behavior + +add_method_modifier (and subsequently the sugar functions Moose::before, +Moose::after, and Moose::around) can now accept arrayrefs, with the same +behavior as lists. Types other than arrayref and regexp result in an error. + +=back + +=head1 0.93_01 and 0.94 + +=over 4 + +=item Moose::Util::MetaRole API has changed + +The C<apply_metaclass_roles> function is now called C<apply_metaroles>. The +way arguments are supplied has been changed to force you to distinguish +between metaroles applied to L<Moose::Meta::Class> (and helpers) versus +L<Moose::Meta::Role>. + +The old API still works, but will warn in a future release, and eventually be +removed. + +=item Moose::Meta::Role has real attributes + +The attributes returned by L<Moose::Meta::Role> are now instances of the +L<Moose::Meta::Role::Attribute> class, instead of bare hash references. + +=item "no Moose" now removes C<blessed> and C<confess> + +Moose is now smart enough to know exactly what it exported, even when it +re-exports functions from other packages. When you unimport Moose, it will +remove these functions from your namespace unless you I<also> imported them +directly from their respective packages. + +If you have a C<no Moose> in your code I<before> you call C<blessed> or +C<confess>, your code will break. You can either move the C<no Moose> call +later in your code, or explicitly import the relevant functions from the +packages that provide them. + +=item L<Moose::Exporter> is smarter about unimporting re-exports + +The change above comes from a general improvement to L<Moose::Exporter>. It +will now unimport any function it exports, even if that function is a +re-export from another package. + +=item Attributes in roles can no longer override class attributes with "+foo" + +Previously, this worked more or less accidentally, because role attributes +weren't objects. This was never documented, but a few MooseX modules took +advantage of this. + +=item The composition_class_roles attribute in L<Moose::Meta::Role> is now a method + +This was done to make it possible for roles to alter the list of composition +class roles by applying a method modifiers. Previously, this was an attribute +and MooseX modules override it. Since that no longer works, this was made a +method. + +This I<should> be an attribute, so this may switch back to being an attribute +in the future if we can figure out how to make this work. + +=back + +=head1 0.93 + +=over 4 + +=item Calling $object->new() is no longer deprecated + +We decided to undeprecate this. Now it just works. + +=item Both C<get_method_map> and C<get_attribute_map> is deprecated + +These metaclass methods were never meant to be public, and they are both now +deprecated. The work around if you still need the functionality they provided +is to iterate over the list of names manually. + + my %fields = map { $_ => $meta->get_attribute($_) } $meta->get_attribute_list; + +This was actually a change in L<Class::MOP>, but this version of Moose +requires a version of L<Class::MOP> that includes said change. + +=back + +=head1 0.90 + +=over 4 + +=item Added Native delegation for Code refs + +See L<Moose::Meta::Attribute::Native::Trait::Code> for details. + +=item Calling $object->new() is deprecated + +Moose has long supported this, but it's never really been documented, and we +don't think this is a good practice. If you want to construct an object from +an existing object, you should provide some sort of alternate constructor like +C<< $object->clone >>. + +Calling C<< $object->new >> now issues a warning, and will be an error in a +future release. + +=item Moose no longer warns if you call C<make_immutable> for a class with mutable ancestors + +While in theory this is a good thing to warn about, we found so many +exceptions to this that doing this properly became quite problematic. + +=back + +=head1 0.89_02 + +=over 4 + +=item New Native delegation methods from L<List::Util> and L<List::MoreUtils> + +In particular, we now have C<reduce>, C<shuffle>, C<uniq>, and C<natatime>. + +=item The Moose::Exporter with_caller feature is now deprecated + +Use C<with_meta> instead. The C<with_caller> option will start warning in a +future release. + +=item Moose now warns if you call C<make_immutable> for a class with mutable ancestors + +This is dangerous because modifying a class after a subclass has been +immutabilized will lead to incorrect results in the subclass, due to inlining, +caching, etc. This occasionally happens accidentally, when a class loads one +of its subclasses in the middle of its class definition, so pointing out that +this may cause issues should be helpful. Metaclasses (classes that inherit +from L<Class::MOP::Object>) are currently exempt from this check, since at the +moment we aren't very consistent about which metaclasses we immutabilize. + +=item C<enum> and C<duck_type> now take arrayrefs for all forms + +Previously, calling these functions with a list would take the first element of +the list as the type constraint name, and use the remainder as the enum values +or method names. This makes the interface inconsistent with the anon-type forms +of these functions (which must take an arrayref), and a free-form list where +the first value is sometimes special is hard to validate (and harder to give +reasonable error messages for). These functions have been changed to take +arrayrefs in all their forms - so, C<< enum 'My::Type' => [qw(foo bar)] >> is +now the preferred way to create an enum type constraint. The old syntax still +works for now, but it will hopefully be deprecated and removed in a future +release. + +=back + +=head1 0.89_01 + +L<Moose::Meta::Attribute::Native> has been moved into the Moose core from +L<MooseX::AttributeHelpers>. Major changes include: + +=over 4 + +=item C<traits>, not C<metaclass> + +Method providers are only available via traits. + +=item C<handles>, not C<provides> or C<curries> + +The C<provides> syntax was like core Moose C<< handles => HASHREF >> +syntax, but with the keys and values reversed. This was confusing, +and AttributeHelpers now uses C<< handles => HASHREF >> in a way that +should be intuitive to anyone already familiar with how it is used for +other attributes. + +The C<curries> functionality provided by AttributeHelpers has been +generalized to apply to all cases of C<< handles => HASHREF >>, though +not every piece of functionality has been ported (currying with a +CODEREF is not supported). + +=item C<empty> is now C<is_empty>, and means empty, not non-empty + +Previously, the C<empty> method provided by Arrays and Hashes returned true if +the attribute was B<not> empty (no elements). Now it returns true if the +attribute B<is> empty. It was also renamed to C<is_empty>, to reflect this. + +=item C<find> was renamed to C<first>, and C<first> and C<last> were removed + +L<List::Util> refers to the functionality that we used to provide under C<find> +as L<first|List::Util/first>, so that will likely be more familiar (and will +fit in better if we decide to add more List::Util functions). C<first> and +C<last> were removed, since their functionality is easily duplicated with +curries of C<get>. + +=item Helpers that take a coderef of one argument now use C<$_> + +Subroutines passed as the first argument to C<first>, C<map>, and C<grep> now +receive their argument in C<$_> rather than as a parameter to the subroutine. +Helpers that take a coderef of two or more arguments remain using the argument +list (there are technical limitations to using C<$a> and C<$b> like C<sort> +does). + +See L<Moose::Meta::Attribute::Native> for the new documentation. + +=back + +The C<alias> and C<excludes> role parameters have been renamed to C<-alias> +and C<-excludes>. The old names still work, but new code should use the new +names, and eventually the old ones will be deprecated and removed. + +=head1 0.89 + +C<< use Moose -metaclass => 'Foo' >> now does alias resolution, just like +C<-traits> (and the C<metaclass> and C<traits> options to C<has>). + +Added two functions C<meta_class_alias> and C<meta_attribute_alias> to +L<Moose::Util>, to simplify aliasing metaclasses and metatraits. This is +a wrapper around the old + + package Moose::Meta::Class::Custom::Trait::FooTrait; + sub register_implementation { 'My::Meta::Trait' } + +way of doing this. + +=head1 0.84 + +When an attribute generates I<no> accessors, we now warn. This is to help +users who forget the C<is> option. If you really do not want any accessors, +you can use C<< is => 'bare' >>. You can maintain back compat with older +versions of Moose by using something like: + + ($Moose::VERSION >= 0.84 ? is => 'bare' : ()) + +When an accessor overwrites an existing method, we now warn. To work around +this warning (if you really must have this behavior), you can explicitly +remove the method before creating it as an accessor: + + sub foo {} + + __PACKAGE__->meta->remove_method('foo'); + + has foo => ( + is => 'ro', + ); + +When an unknown option is passed to C<has>, we now warn. You can silence +the warning by fixing your code. :) + +The C<Role> type has been deprecated. On its own, it was useless, +since it just checked C<< $object->can('does') >>. If you were using +it as a parent type, just call C<role_type('Role::Name')> to create an +appropriate type instead. + +=head1 0.78 + +C<use Moose::Exporter;> now imports C<strict> and C<warnings> into packages +that use it. + +=head1 0.77 + +C<DEMOLISHALL> and C<DEMOLISH> now receive an argument indicating whether or +not we are in global destruction. + +=head1 0.76 + +Type constraints no longer run coercions for a value that already matches the +constraint. This may affect some (arguably buggy) edge case coercions that +rely on side effects in the C<via> clause. + +=head1 0.75 + +L<Moose::Exporter> now accepts the C<-metaclass> option for easily +overriding the metaclass (without L<metaclass>). This works for classes +and roles. + +=head1 0.74 + +Added a C<duck_type> sugar function to L<Moose::Util::TypeConstraints> +to make integration with non-Moose classes easier. It simply checks if +C<< $obj->can() >> a list of methods. + +A number of methods (mostly inherited from L<Class::MOP>) have been +renamed with a leading underscore to indicate their internal-ness. The +old method names will still work for a while, but will warn that the +method has been renamed. In a few cases, the method will be removed +entirely in the future. This may affect MooseX authors who were using +these methods. + +=head1 0.73 + +Calling C<subtype> with a name as the only argument now throws an +exception. If you want an anonymous subtype do: + + my $subtype = subtype as 'Foo'; + +This is related to the changes in version 0.71_01. + +The C<is_needed> method in L<Moose::Meta::Method::Destructor> is now +only usable as a class method. Previously, it worked as a class or +object method, with a different internal implementation for each +version. + +The internals of making a class immutable changed a lot in Class::MOP +0.78_02, and Moose's internals have changed along with it. The +external C<< $metaclass->make_immutable >> method still works the same +way. + +=head1 0.72 + +A mutable class accepted C<< Foo->new(undef) >> without complaint, +while an immutable class would blow up with an unhelpful error. Now, +in both cases we throw a helpful error instead. + +This "feature" was originally added to allow for cases such as this: + + my $args; + + if ( something() ) { + $args = {...}; + } + + return My::Class->new($args); + +But we decided this is a bad idea and a little too magical, because it +can easily mask real errors. + +=head1 0.71_01 + +Calling C<type> or C<subtype> without the sugar helpers (C<as>, +C<where>, C<message>) is now deprecated. + +As a side effect, this meant we ended up using Perl prototypes on +C<as>, and code like this will no longer work: + + use Moose::Util::TypeConstraints; + use Declare::Constraints::Simple -All; + + subtype 'ArrayOfInts' + => as 'ArrayRef' + => IsArrayRef(IsInt); + +Instead it must be changed to this: + + subtype( + 'ArrayOfInts' => { + as => 'ArrayRef', + where => IsArrayRef(IsInt) + } + ); + +If you want to maintain backwards compat with older versions of Moose, +you must explicitly test Moose's C<VERSION>: + + if ( Moose->VERSION < 0.71_01 ) { + subtype 'ArrayOfInts' + => as 'ArrayRef' + => IsArrayRef(IsInt); + } + else { + subtype( + 'ArrayOfInts' => { + as => 'ArrayRef', + where => IsArrayRef(IsInt) + } + ); + } + +=head1 0.70 + +We no longer pass the meta-attribute object as a final argument to +triggers. This actually changed for inlined code a while back, but the +non-inlined version and the docs were still out of date. + +If by some chance you actually used this feature, the workaround is +simple. You fetch the attribute object from out of the C<$self> +that is passed as the first argument to trigger, like so: + + has 'foo' => ( + is => 'ro', + isa => 'Any', + trigger => sub { + my ( $self, $value ) = @_; + my $attr = $self->meta->find_attribute_by_name('foo'); + + # ... + } + ); + +=head1 0.66 + +If you created a subtype and passed a parent that Moose didn't know +about, it simply ignored the parent. Now it automatically creates the +parent as a class type. This may not be what you want, but is less +broken than before. + +You could declare a name with subtype such as "Foo!Bar". Moose would +accept this allowed, but if you used it in a parameterized type such +as "ArrayRef[Foo!Bar]" it wouldn't work. We now do some vetting on +names created via the sugar functions, so that they can only contain +alphanumerics, ":", and ".". + +=head1 0.65 + +Methods created via an attribute can now fulfill a C<requires> +declaration for a role. Honestly we don't know why Stevan didn't make +this work originally, he was just insane or something. + +Stack traces from inlined code will now report the line and file as +being in your class, as opposed to in Moose guts. + +=head1 0.62_02 + +When a class does not provide all of a role's required methods, the +error thrown now mentions all of the missing methods, as opposed to +just the first missing method. + +Moose will no longer inline a constructor for your class unless it +inherits its constructor from Moose::Object, and will warn when it +doesn't inline. If you want to force inlining anyway, pass +C<< replace_constructor => 1 >> to C<make_immutable>. + +If you want to get rid of the warning, pass C<< inline_constructor => +0 >>. + +=head1 0.62 + +Removed the (deprecated) C<make_immutable> keyword. + +Removing an attribute from a class now also removes delegation +(C<handles>) methods installed for that attribute. This is correct +behavior, but if you were wrongly relying on it you might get bit. + +=head1 0.58 + +Roles now add methods by calling C<add_method>, not +C<alias_method>. They make sure to always provide a method object, +which will be cloned internally. This means that it is now possible to +track the source of a method provided by a role, and even follow its +history through intermediate roles. This means that methods added by +a role now show up when looking at a class's method list/map. + +Parameter and Union args are now sorted, this makes Int|Str the same +constraint as Str|Int. Also, incoming type constraint strings are +normalized to remove all whitespace differences. This is mostly for +internals and should not affect outside code. + +L<Moose::Exporter> will no longer remove a subroutine that the +exporting package re-exports. Moose re-exports the Carp::confess +function, among others. The reasoning is that we cannot know whether +you have also explicitly imported those functions for your own use, so +we err on the safe side and always keep them. + +=head1 0.56 + +C<Moose::init_meta> should now be called as a method. + +New modules for extension writers, L<Moose::Exporter> and +L<Moose::Util::MetaRole>. + +=head1 0.55_01 + +Implemented metaclass traits (and wrote a recipe for it): + + use Moose -traits => 'Foo' + +This should make writing small Moose extensions a little +easier. + +=head1 0.55 + +Fixed C<coerce> to accept anon types just like C<subtype> can. +So that you can do: + + coerce $some_anon_type => from 'Str' => via { ... }; + +=head1 0.51 + +Added C<BUILDARGS>, a new step in C<< Moose::Object->new() >>. + +=head1 0.49 + +Fixed how the C<< is => (ro|rw) >> works with custom defined +C<reader>, C<writer> and C<accessor> options. See the below table for +details: + + is => ro, writer => _foo # turns into (reader => foo, writer => _foo) + is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + is => rw, accessor => _foo # turns into (accessor => _foo) + is => ro, accessor => _foo # error, accesor is rw + +=head1 0.45 + +The C<before/around/after> method modifiers now support regexp +matching of method names. NOTE: this only works for classes, it is +currently not supported in roles, but, ... patches welcome. + +The C<has> keyword for roles now accepts the same array ref form that +L<Moose>.pm does for classes. + +A trigger on a read-only attribute is no longer an error, as it's +useful to trigger off of the constructor. + +Subtypes of parameterizable types now are parameterizable types +themselves. + +=head1 0.44 + +Fixed issue where C<DEMOLISHALL> was eating the value in C<$@>, and so +not working correctly. It still kind of eats them, but so does vanilla +perl. + +=head1 0.41 + +Inherited attributes may now be extended without restriction on the +type ('isa', 'does'). + +The entire set of Moose::Meta::TypeConstraint::* classes were +refactored in this release. If you were relying on their internals you +should test your code carefully. + +=head1 0.40 + +Documenting the use of '+name' with attributes that come from recently +composed roles. It makes sense, people are using it, and so why not +just officially support it. + +The C<< Moose::Meta::Class->create >> method now supports roles. + +It is now possible to make anonymous enum types by passing C<enum> an +array reference instead of the C<< enum $name => @values >>. + +=head1 0.37 + +Added the C<make_immutable> keyword as a shortcut to calling +C<make_immutable> on the meta object. This eventually got removed! + +Made C<< init_arg => undef >> work in Moose. This means "do not accept +a constructor parameter for this attribute". + +Type errors now use the provided message. Prior to this release they +didn't. + +=head1 0.34 + +Moose is now a postmodern object system :) + +The Role system was completely refactored. It is 100% backwards +compat, but the internals were totally changed. If you relied on the +internals then you are advised to test carefully. + +Added method exclusion and aliasing for Roles in this release. + +Added the L<Moose::Util::TypeConstraints::OptimizedConstraints> +module. + +Passing a list of values to an accessor (which is only expecting one +value) used to be silently ignored, now it throws an error. + +=head1 0.26 + +Added parameterized types and did a pretty heavy refactoring of the +type constraint system. + +Better framework extensibility and better support for "making your own +Moose". + +=head1 0.25 or before + +Honestly, you shouldn't be using versions of Moose that are this old, +so many bug fixes and speed improvements have been made you would be +crazy to not upgrade. + +Also, I am tired of going through the Changelog so I am stopping here, +if anyone would like to continue this please feel free. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Exceptions.pod b/lib/Moose/Manual/Exceptions.pod new file mode 100644 index 0000000..61435a2 --- /dev/null +++ b/lib/Moose/Manual/Exceptions.pod @@ -0,0 +1,239 @@ +# PODNAME: Moose::Manual::Exceptions +# ABSTRACT: Moose's exceptions + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Exceptions - Moose's exceptions + +=head1 VERSION + +version 2.1405 + +=head1 EXCEPTIONS IN MOOSE + +Moose will throw an exception for all error conditions. This applies both to +code in the Moose core I<as well> as to all code generated when a class is +made immutable. All exceptions are subclasses of the C<Moose::Exception> +class. + +Each type of error has its own unique subclass, and many subclasses have +additional attributes to provide more information about the error's context, +such as what classes or roles were involved. + +=head1 EXCEPTION STRINGIFICATION + +By default, Moose exceptions remove Moose internals from the stack trace. If +you set the C<MOOSE_FULL_EXCEPTION> environment variable to a true value, then +the Moose internals will be included in the trace. + +=head1 HANDLING MOOSE EXCEPTIONS + +Because Moose's exceptions use the standard C<die> mechanism, you are free to +catch and handle errors however you like. You could use an C<eval> block to +catch Moose exceptions. However, the Moose team strongly recommends using +L<Try::Tiny> instead. Please refer to L<Try::Tiny>'s documentation for a +discussion of how C<eval> is dangerous. + +The following example demonstrates how to catch and inspect a +L<Moose::Exception>. For the sake of simplicity, we will cause a very simple +error. The C<extends> keywords expects a list of superclass names. If we pass +no superclass names, Moose will throw an instance of +L<Moose::Exception::ExtendsMissingArgs>. + +=head2 Catching with Try::Tiny + + use warnings; + use strict; + use Try::Tiny; + + try { + package Example::Exception; + use Moose; + extends; # <-- error! + } + catch { + # $_ contains the instance of the exception thrown by the above try + # block, but $_ may get clobbered, so we should copy its value to + # another variable. + my $e = $_; + + # Exception objects are not ubiquitous in Perl, so we must check + # whether $e is blessed. We also need to ensure that $e is actually + # the kind of exception we were expecting. + if ( blessed $e + && $e->isa('Moose::Exception::ExtendsMissingArgs') ) { + + my $class_name = $e->class_name; + warn "You forgot to specify a superclass for $class_name, silly!"; + } + + # It's either another type of an object or not an object at all. + else { + warn "$e\n"; + } + } + +=head2 Example of catching ValidationFailedForTypeConstraint + + use warnings; + use strict; + + use Try::Tiny; + + { + package Person; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'NameStr', + as 'Str', + where { $_ =~ /^[a-zA-Z]+$/; }; + + has age => ( + is => 'ro', + isa => 'Int', + required => 1 + ); + + has name => ( + is => 'ro', + isa => 'NameStr', + required => 1 + ); + } + + my $person; + while ( !$person ) { + try { + print 'Enter your age : '; + my $age = <STDIN>; + chomp $age; + print 'Enter your name : '; + my $name = <STDIN>; + chomp $name; + $person = Person->new( + age => $age, + name => $name + ); + my $person_name = $person->name; + my $person_age = $person->age; + print "$person_name is $person_age years old\n"; + } + catch { + my $e = $_; + + if ( + blessed $e + && $e->isa( + 'Moose::Exception::ValidationFailedForTypeConstraint') + ) { + + my $attribute_name = $e->attribute->name; + my $type_name = $e->type->name; + my $value = $e->value; + + warn + "You entered $value for $attribute_name, which is not a $type_name!"; + } + else { + warn "$e\n"; + } + } + } + +=head2 Example of catching AttributeIsRequired + + use warnings; + use strict; + use Try::Tiny; + + { + package Example::RequiredAttribute; + use Moose; + + has required_attribute => ( + is => 'ro', + isa => 'Int', + required => 1 + ); + } + + try { + # we're not passing required_attribute, so it'll throw an exception + my $object = Example::RequiredAttribute->new(); + } + catch { + my $e = $_; + if ( blessed $e && $e->isa('Moose::Exception::AttributeIsRequired') ) + { + warn $e->message, "\n"; + } + else { + warn "$e\n"; + } + }; + +=head1 MOOSE EXCEPTION CLASSES + +All the exception classes are listed in L<Moose::Manual::Exceptions::Manifest>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Exceptions/Manifest.pod b/lib/Moose/Manual/Exceptions/Manifest.pod new file mode 100644 index 0000000..3fd0e68 --- /dev/null +++ b/lib/Moose/Manual/Exceptions/Manifest.pod @@ -0,0 +1,8343 @@ +# PODNAME: Moose::Manual::Exceptions::Manifest +# ABSTRACT: Moose's Exception Types + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Exceptions::Manifest - Moose's Exception Types + +=head1 VERSION + +version 2.1405 + +=head1 Moose::Exception::AccessorMustReadWrite + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot define an accessor name on a read-only attribute, accessors are read/ +write + +=head1 Moose::Exception::AddParameterizableTypeTakesParameterizableType + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Message: + + Type must be a Moose::Meta::TypeConstraint::Parameterizable not Foo + +=head1 Moose::Exception::AddRoleTakesAMooseMetaRoleInstance + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_to_be_added >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Roles must be instances of Moose::Meta::Role + +=head1 Moose::Exception::AddRoleToARoleTakesAMooseMetaRole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->role_to_be_added >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Roles must be instances of Moose::Meta::Role + +=head1 Moose::Exception::ApplyTakesABlessedInstance + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->param >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass in an blessed instance + +=head1 Moose::Exception::AttachToClassNeedsAClassMOPClassInstanceOrASubclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->class >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a Class::MOP::Class instance (or a subclass) + +=head1 Moose::Exception::AttributeConflictInRoles + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->second_role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Role 'Foo4' has encountered an attribute conflict while being composed into +'Bar4'. This is a fatal error and cannot be disambiguated. The conflicting +attribute is named 'foo'. + +=head1 Moose::Exception::AttributeConflictInSummation + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::AttributeName>, L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->second_role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + We have encountered an attribute conflict with 'foo' during role composition +. This attribute is defined in both Foo2 and Bar2. This is a fatal error and +cannot be disambiguated. + +=head1 Moose::Exception::AttributeExtensionIsNotSupportedInRoles + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + has '+attr' is not supported in roles + +=head1 Moose::Exception::AttributeIsRequired + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute can be used for fetching attribute instance: + my $class = Moose::Util::find_meta( $exception->class_name ); + my $attribute = $class->get_attribute( $exception->attribute_name ); + + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef, has a predicate C<has_params> and is +optional. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Attribute (baz) is required + Attribute (bar) is required + Attribute (foo_required) is required + Attribute (baz) is required + +=head1 Moose::Exception::AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a + subclass) + +=head1 Moose::Exception::AttributeNamesDoNotMatch + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute> and is required. + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + attribute_name (foo) does not match attribute->name (bar) + +=head1 Moose::Exception::AttributeValueIsNotAnObject + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Attribute>, L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->given_value >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method::Delegation> and is +required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot delegate get_count to count because the value of foo is not an object + (got 'ARRAY(0x223f578)') + +=head1 Moose::Exception::AttributeValueIsNotDefined + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Attribute>, L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method::Delegation> and is +required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot delegate get_count to count because the value of foo is not defined + +=head1 Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot auto-dereference anything other than a ArrayRef or HashRef on +attribute (bar) + +=head1 Moose::Exception::BadOptionFormat + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->option_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->option_value >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + bad accessor/reader/writer/predicate/clearer format, must be a HASH ref + +=head1 Moose::Exception::BothBuilderAndDefaultAreNotAllowed + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Setting both default and builder is not allowed. + +=head1 Moose::Exception::BuilderDoesNotExist + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Attribute> and L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Foo does not support builder method '_build_baz' for attribute 'baz' + +=head1 Moose::Exception::BuilderMethodNotSupportedForAttribute + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Attribute> and L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Class::MOP::Attribute does not support builder method 'foo' for attribute +'bar' + +=head1 Moose::Exception::BuilderMethodNotSupportedForInlineAttribute + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->builder >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Test::LazyBuild::Attribute does not support builder method '_build_fool' for + attribute 'fool' + +=head1 Moose::Exception::BuilderMustBeAMethodName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + builder must be a defined scalar value which is a method name + +=head1 Moose::Exception::CallingMethodOnAnImmutableInstance + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The 'add_method' method cannot be called on an immutable instance + +=head1 Moose::Exception::CallingReadOnlyMethodOnAnImmutableInstance + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The 'superclasses' method is read-only when called on an immutable instance + +=head1 Moose::Exception::CanExtendOnlyClasses + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot inherit from a Moose Role (Bar) + +=head1 Moose::Exception::CanOnlyConsumeRole + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You can only consume roles, Module::Runtime is not a Moose role + +=head1 Moose::Exception::CanOnlyWrapBlessedCode + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->code >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Can only wrap blessed CODE + +=head1 Moose::Exception::CanReblessOnlyIntoASubclass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::Instance>, +L<Moose::Exception::Role::InstanceClass>, L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->instance_class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You may rebless only into a subclass of (Foo2), of which (Foo) isn't. + +=head1 Moose::Exception::CanReblessOnlyIntoASuperclass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::Instance> and +L<Moose::Exception::Role::InstanceClass>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->instance_class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You may rebless only into a superclass of (Foo), of which (Foo2) isn't. + +=head1 Moose::Exception::CannotAddAdditionalTypeCoercionsToUnion + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_coercion_union_object >> + +This attribute is read-only, isa L<Moose::Meta::TypeCoercion::Union> and is +required. + +=back + +=head4 Sample Error Message: + + Cannot add additional type coercions to Union types + +=head1 Moose::Exception::CannotAddAsAnAttributeToARole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot add a Moose::Meta::Class as an attribute to a role + +=head1 Moose::Exception::CannotApplyBaseClassRolesToRole + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You can only apply base class roles to a Moose class, not a role. + +=head1 Moose::Exception::CannotAssignValueToReadOnlyAccessor + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and +L<Moose::Exception::Role::EitherAttributeOrAttributeName>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<has_attribute> and is optional. + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str, has a predicate C<has_attribute_name> and +is optional. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef, has a predicate C<has_params> and is +optional. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->value >> + +This attribute is read-only, isa Any and is required. + +=back + +=head4 Sample Error Message: + + Cannot assign a value to a read-only accessor + +=head1 Moose::Exception::CannotAugmentIfLocalMethodPresent + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::Method>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method> and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot add an augment method if a local method is already present + +=head1 Moose::Exception::CannotAugmentNoSuperMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot augment 'foo' because it has no super method + +=head1 Moose::Exception::CannotAutoDerefWithoutIsa + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot auto-dereference without specifying a type constraint on +attribute (bar) + +=head1 Moose::Exception::CannotAutoDereferenceTypeConstraint + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Attribute>, L<Moose::Exception::Role::Instance> and +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Can not auto de-reference the type constraint 'Int' + +=head1 Moose::Exception::CannotCalculateNativeType + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot calculate native type for Moose::Meta::Class::__ANON__::SERIAL:: + +=head1 Moose::Exception::CannotCallAnAbstractBaseMethod + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->package_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Class::MOP::Method::Generated is an abstract base class, you must provide a +constructor. + +=head1 Moose::Exception::CannotCallAnAbstractMethod + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Abstract method + +=head1 Moose::Exception::CannotCoerceAWeakRef + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot have a weak reference to a coerced value on attribute (bar) + +=head1 Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions>, +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + You cannot coerce an attribute (foo) unless its type (Str) has a coercion + +=head1 Moose::Exception::CannotCreateHigherOrderTypeWithoutATypeParameter + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + You cannot create a Higher Order type without a type parameter + +=head1 Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresent + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Method>, L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->aliased_method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method> and is required. + +=item B<< $exception->role_being_applied_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot create a method alias if a local method of the same name exists + +=head1 Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresentInClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::Method>, +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->aliased_method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method> and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot create a method alias if a local method of the same name exists + +=head1 Moose::Exception::CannotDelegateLocalMethodIsPresent + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Attribute> and L<Moose::Exception::Role::Method>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method> and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot overwrite a locally defined method (full) with a delegation + +=head1 Moose::Exception::CannotDelegateWithoutIsa + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot delegate methods based on a Regexp without a type constraint (isa) + +=head1 Moose::Exception::CannotFindDelegateMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot find delegate metaclass for attribute bar + +=head1 Moose::Exception::CannotFindType + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Message: + + Cannot find type 'Foo', perhaps you forgot to load it + +=head1 Moose::Exception::CannotFindTypeGivenToMatchOnType + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->action >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->to_match >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type >> + +This attribute is read-only, isa Any and is required. + +=back + +=head4 Sample Error Message: + + Cannot find or parse the type 'doesNotExist' + +=head1 Moose::Exception::CannotFixMetaclassCompatibility + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass_type >> + +This attribute is read-only, isa Str and is optional. + +=item B<< $exception->superclass >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Can't fix metaclass incompatibility for Foo9 because it is not pristine. + Can't fix metaclass incompatibility for Foo::Unsafe::Sub because it is not +pristine. + +=head1 Moose::Exception::CannotGenerateInlineConstraint + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->parameterizable_type_object_name >> + +This attribute can be used for fetching parameterizable type +constraint(Moose::Meta::TypeConstraint::Parameterizable): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + + +=item B<< $exception->value >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Message: + + Can't generate an inline constraint for Int, since none was defined + +=head1 Moose::Exception::CannotInitializeMooseMetaRoleComposite + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->args >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->old_meta >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->role_composite >> + +This attribute is read-only, isa L<Moose::Meta::Role::Composite> and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Moose::Meta::Role::Composite instances can only be reinitialized from an +existing metaclass instance + +=head1 Moose::Exception::CannotInlineTypeConstraintCheck + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Cannot inline a type constraint check for NotInlinable + +=head1 Moose::Exception::CannotLocatePackageInINC + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->INC >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->possible_packages >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Message: + + Can't locate Moose::Meta::Attribute::Custom::Trait::Xyz or Xyz in \@INC \(\@ +INC contains: + +=head1 Moose::Exception::CannotMakeMetaclassCompatible + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->superclass_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::CannotOverrideALocalMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot add an override of method 'bar' because there is a local version of +'bar' + +=head1 Moose::Exception::CannotOverrideBodyOfMetaMethods + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Overriding the body of meta methods is not allowed + +=head1 Moose::Exception::CannotOverrideLocalMethodIsPresent + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::Method>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method >> + +This attribute is read-only, isa L<Moose::Meta::Method> and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot add an override method if a local method is already present + +=head1 Moose::Exception::CannotOverrideNoSuperMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot override 'foo' because it has no super method + +=head1 Moose::Exception::CannotRegisterUnnamedTypeConstraint + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + can't register an unnamed type constraint + +=head1 Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You can not use lazy_build and default for the same attribute (bar) + +=head1 Moose::Exception::CircularReferenceInAlso + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->also_parameter >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->stack >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Circular reference in 'also' parameter to Moose::Exporter between +MooseX::CircularAlso and MooseX::CircularAlso + +=head1 Moose::Exception::ClassDoesNotHaveInitMeta + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->traits >> + +This attribute is read-only, isa ArrayRef and is required. + +=back + +=head4 Sample Error Message: + + Cannot provide traits when Moose::Util::TypeConstraints does not have an +init_meta() method + +=head1 Moose::Exception::ClassDoesTheExcludedRole + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->excluded_role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The class FooClass2 does the excluded role 'ExcludedRole2' + +=head1 Moose::Exception::ClassNamesDoNotMatch + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa L<Class::MOP::Class> and is required. + +=item B<< $exception->class_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an instance of the metaclass (Foo), not (foo) + +=head1 Moose::Exception::CodeBlockMustBeACodeRef + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Instance>, L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Your code block must be a CODE reference + +=head1 Moose::Exception::CoercingWithoutCoercions + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Cannot coerce without a type coercion + +=head1 Moose::Exception::CoercionAlreadyExists + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->constraint_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + A coercion action already exists for 'Int' + +=head1 Moose::Exception::CoercionNeedsTypeConstraint + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot have coercion without specifying a type constraint on attribute +(bar) + +=head1 Moose::Exception::ConflictDetectedInCheckRoleExclusions + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->excluded_role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Conflict detected: Foo excludes role 'Bar' + +=head1 Moose::Exception::ConflictDetectedInCheckRoleExclusionsInToClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Conflict detected: FooClass excludes role 'BarRole' + +=head1 Moose::Exception::ConstructClassInstanceTakesPackageName + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a package name + +=head1 Moose::Exception::CouldNotCreateMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->error >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->option_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->option_value >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Could not create the 'predicate' method for bar because : Can't call method +"name" on an undefined value + +=head1 Moose::Exception::CouldNotCreateWriter + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::EitherAttributeOrAttributeName> and +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<has_attribute> and is optional. + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str, has a predicate C<has_attribute_name> and +is optional. + +=item B<< $exception->error >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef, has a predicate C<has_params> and is +optional. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Could not generate inline writer because : Could not create writer for 'bar' + because Can't locate object method "_eval_environment" via package +"Class::MOP::Attribute" + +=head1 Moose::Exception::CouldNotEvalConstructor + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->constructor_method >> + +This attribute is read-only, isa L<Class::MOP::Method::Constructor> and is +required. + +=item B<< $exception->error >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->source >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Could not eval the constructor : + +=head1 Moose::Exception::CouldNotEvalDestructor + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->error >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_destructor_object >> + +This attribute is read-only, isa L<Moose::Meta::Method::Destructor> and is +required. + +=item B<< $exception->source >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Could not eval the destructor + +=head1 Moose::Exception::CouldNotFindTypeConstraintToCoerceFrom + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->constraint_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Could not find the type constraint (xyz) to coerce from + +=head1 Moose::Exception::CouldNotGenerateInlineAttributeMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->error >> + +This attribute is read-only, isa L<Moose::Exception|Str> and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->option >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Could not generate inline accessor because : Can't call method +"get_meta_instance" on an undefined value + Could not generate inline reader because : Can't call method +"get_meta_instance" on an undefined value + Could not generate inline writer because : Can't call method +"get_meta_instance" on an undefined value + Could not generate inline predicate because : Can't call method +"get_meta_instance" on an undefined value + Could not generate inline clearer because : Can't call method +"get_meta_instance" on an undefined value + +=head1 Moose::Exception::CouldNotLocateTypeConstraintForUnion + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Could not locate type constraint (foo) for the union + +=head1 Moose::Exception::CouldNotParseType + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->position >> + +This attribute is read-only, isa Int and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Message: + + 'Str | Undef |' didn't parse (parse-pos=11 and str-length=13) + +=head1 Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::RoleForCreateMOPClass>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an ARRAY ref of attributes + +=head1 Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::RoleForCreateMOPClass>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an ARRAY ref of superclasses + +=head1 Moose::Exception::CreateMOPClassTakesHashRefOfMethods + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::RoleForCreateMOPClass>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an HASH ref of methods + +=head1 Moose::Exception::CreateTakesArrayRefOfRoles + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::RoleForCreate>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an ARRAY ref of roles + +=head1 Moose::Exception::CreateTakesHashRefOfAttributes + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::RoleForCreate>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a HASH ref of attributes + +=head1 Moose::Exception::CreateTakesHashRefOfMethods + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::ParamsHash> and +L<Moose::Exception::Role::RoleForCreate>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a HASH ref of methods + +=head1 Moose::Exception::DefaultToMatchOnTypeMustBeCodeRef + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->cases_to_be_matched >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->default_action >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->to_match >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Default case must be a CODE ref, not ARRAY(0x14f6fc8) + +=head1 Moose::Exception::DelegationToAClassWhichIsNotLoaded + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->class_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The bar attribute is trying to delegate to a class which has not been loaded + - Not::Loaded + +=head1 Moose::Exception::DelegationToARoleWhichIsNotLoaded + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The bar attribute is trying to delegate to a role which has not been loaded +- Role + +=head1 Moose::Exception::DelegationToATypeWhichIsNotAClass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + The bar attribute is trying to delegate to a type (Int) that is not backed +by a class + The bar attribute is trying to delegate to a type (PositiveInt) that is not +backed by a class + +=head1 Moose::Exception::DoesRequiresRoleName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply a role name to does() + +=head1 Moose::Exception::EnumCalledWithAnArrayRefAndAdditionalArgs + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->args >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->array >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + enum called with an array reference and additional arguments. Did you mean +to parenthesize the enum call's parameters? + +=head1 Moose::Exception::EnumValuesMustBeString + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->value >> + +This attribute is read-only, isa Any and is required. + +=back + +=head4 Sample Error Messages: + + Enum values must be strings, not undef + Enum values must be strings, not 'ARRAY(0x191d1b8)' + +=head1 Moose::Exception::ExtendsMissingArgs + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Must derive at least one class + +=head1 Moose::Exception::HandlesMustBeAHashRef + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->given_handles >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The 'handles' option must be a HASH reference, not bar + +=head1 Moose::Exception::IllegalInheritedOptions + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->illegal_options >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Illegal inherited options => (clearer) + +=head1 Moose::Exception::IllegalMethodTypeToAddMethodModifier + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_or_object >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->modifier_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->params >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Methods passed to before must be provided as a list, arrayref or regex, not +HASH + +=head1 Moose::Exception::IncompatibleMetaclassOfSuperclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_meta_type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->superclass_meta_type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->superclass_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The metaclass of My::Class (Class::MOP::Class) is not compatible with the +metaclass of its superclass, My::Role (Moose::Meta::Role) + +=head1 Moose::Exception::InitMetaRequiresClass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot call init_meta without specifying a for_class + +=head1 Moose::Exception::InitializeTakesUnBlessedPackageName + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->package_name >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a package name and it cannot be blessed + +=head1 Moose::Exception::InstanceBlessedIntoWrongClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::Instance>, +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Objects passed as the __INSTANCE__ parameter must already be blessed into +the correct class, but Bar=HASH(0x2d77528) is not a Foo + +=head1 Moose::Exception::InstanceMustBeABlessedReference + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The __INSTANCE__ parameter must be a blessed reference, not ARRAY(0x1d75d40) + +=head1 Moose::Exception::InvalidArgPassedToMooseUtilMetaRole + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->argument >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + When using Moose::Util::MetaRole, you must pass a Moose class name, role +name, metaclass object, or metarole object. You passed Foo=HASH(0x16adb58), and +we resolved this to a Foo object. + When using Moose::Util::MetaRole, you must pass a Moose class name, role +name, metaclass object, or metarole object. You passed ARRAY(0x21eb868), and +this did not resolve to a metaclass or metarole. Maybe you need to call Moose->i +nit_meta to initialize the metaclass first? + When using Moose::Util::MetaRole, you must pass a Moose class name, role +name, metaclass object, or metarole object. You passed undef, and this did not +resolve to a metaclass or metarole. Maybe you need to call Moose->init_meta to +initialize the metaclass first? + +=head1 Moose::Exception::InvalidArgumentToMethod + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->argument >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->argument_noun >> + +This attribute is read-only, isa Str, has a default value "argument" and is +optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->ordinal >> + +This attribute is read-only, isa Str, has a predicate C<is_ordinal_set> and is +optional. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->type_of_argument >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Messages: + + The index passed to get must be an integer + The argument passed to first must be a code reference + The argument passed to first_index must be a code reference + The argument passed to grep must be a code reference + The argument passed to join must be a string + The argument passed to map must be a code reference + The n value passed to natatime must be an integer + The second argument passed to natatime must be a code reference + The argument passed to reduce must be a code reference + The argument passed to sort must be a code reference + The argument passed to sort_in_place must be a code reference + The length argument passed to splice must be an integer + The argument passed to grep must be a code reference + The key passed to exists must be a defined value + The argument passed to match must be a string or regexp reference + The first argument passed to replace must be a string or regexp reference + The second argument passed to replace must be a string or code reference + The first argument passed to substr must be an integer + The second argument passed to substr must be an integer + The third argument passed to substr must be a string + +=head1 Moose::Exception::InvalidArgumentsToTraitAliases + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->alias >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->package_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + HASH references are not valid arguments to the 'trait_aliases' option + +=head1 Moose::Exception::InvalidBaseTypeGivenToCreateParameterizedTypeConstraint + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Could not locate the base type (Foo) + +=head1 Moose::Exception::InvalidHandleValue + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->handle_value >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + All values passed to handles must be strings or ARRAY references, not (?^:ba +r) + +=head1 Moose::Exception::InvalidHasProvidedInARole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Usage: has 'name' => ( key => value, ... ) + +=head1 Moose::Exception::InvalidNameForType + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + contains invalid characters + +=head1 Moose::Exception::InvalidOverloadOperator + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->operator >> + +This attribute is read-only, isa Defined and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::InvalidRoleApplication + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->application >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Role applications must be instances of +Moose::Meta::Role::Application::ToClass + +=head1 Moose::Exception::InvalidTypeConstraint + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->registry_object >> + +This attribute is read-only, isa L<Moose::Meta::TypeConstraint::Registry> and is + required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type >> + +This attribute is read-only, isa Any and is required. + +=back + +=head4 Sample Error Message: + + No type supplied / type is not a valid type constraint + +=head1 Moose::Exception::InvalidTypeGivenToCreateParameterizedTypeConstraint + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Could not parse type name (Foo) correctly + +=head1 Moose::Exception::InvalidValueForIs + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + I do not understand this option (is => bar) on attribute (foo) + +=head1 Moose::Exception::IsaDoesNotDoTheRole + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot have an isa option and a does option if the isa does not do the does +on attribute (bar) + +=head1 Moose::Exception::IsaLacksDoesMethod + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot have an isa option which cannot ->does() on attribute (bar) + +=head1 Moose::Exception::LazyAttributeNeedsADefault + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::EitherAttributeOrAttributeName>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<has_attribute> and is optional. + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str, has a predicate C<has_attribute_name> and +is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef, has a predicate C<has_params> and is +optional. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot have a lazy attribute (bar) without specifying a default value +for it + +=head1 Moose::Exception::Legacy + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Hello, I am an exception object + An inline error + +=head1 Moose::Exception::MOPAttributeNewNeedsAttributeName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must provide a name for the attribute + +=head1 Moose::Exception::MatchActionMustBeACodeRef + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->action >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->to_match >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Match action must be a CODE ref, not ARRAY(0x27a0748) + +=head1 Moose::Exception::MessageParameterMustBeCodeRef + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The 'message' parameter must be a coderef + +=head1 Moose::Exception::MetaclassIsAClassNotASubclassOfGivenMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Foo3 already has a metaclass, but it does not inherit Moose::Meta::Role +(Moose::Meta::Class=HASH(0x2d5d160)). You cannot make the same thing a role and +a class. Remove either Moose or Moose::Role. + +=head1 Moose::Exception::MetaclassIsARoleNotASubclassOfGivenMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Foo3 already has a metaclass, but it does not inherit Moose::Meta::Class +(Moose::Meta::Role=HASH(0x29d3c78)). You cannot make the same thing a role and a + class. Remove either Moose or Moose::Role. + +=head1 Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Foo4 already has a metaclass, but it does not inherit Moose::Meta::Role +(Class::MOP::Class=HASH(0x2c385a8)). + Foo4 already has a metaclass, but it does not inherit Moose::Meta::Class +(Class::MOP::Class=HASH(0x278a4a0)). + +=head1 Moose::Exception::MetaclassMustBeASubclassOfMooseMetaClass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The Metaclass Foo3 must be a subclass of Moose::Meta::Class. + +=head1 Moose::Exception::MetaclassMustBeASubclassOfMooseMetaRole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The Metaclass Foo3 must be a subclass of Moose::Meta::Role. + +=head1 Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The metaclass (Foo) must be derived from Class::MOP::Class + +=head1 Moose::Exception::MetaclassNotLoaded + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The Metaclass Foo2 must be loaded. (Perhaps you forgot to 'use Foo2'?) + +=head1 Moose::Exception::MetaclassTypeIncompatible + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass_type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->superclass_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The attribute_metaclass metaclass for Foo::All::Sub::Attribute +(Bar::Meta::Attribute) is not compatible with the attribute metaclass of its +superclass, Foo::All (Foo::Meta::Attribute) + +=head1 Moose::Exception::MethodExpectedAMetaclassObject + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->metaclass >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The is_needed method expected a metaclass object as its arugment + +=head1 Moose::Exception::MethodExpectsFewerArgs + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->maximum_args >> + +This attribute is read-only, isa Int and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot call substr with more than 3 arguments + +=head1 Moose::Exception::MethodExpectsMoreArgs + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->minimum_args >> + +This attribute is read-only, isa Int and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Cannot call substr without at least 1 argument + +=head1 Moose::Exception::MethodModifierNeedsMethodName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass in a method name + +=head1 Moose::Exception::MethodNameConflictInRoles + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->conflict >> + +This attribute is read-only, isa +ArrayRef[Moose::Meta::Role::Method::Conflicting] and is required. + +This attribute has handles as follows: + conflict_methods_count => count + get_all_methods => elements + get_method_at => get + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the +method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken' + Due to method name conflicts in roles 'Bar2::Role' and 'Foo2::Role', the +methods 'bar' and 'foo' must be implemented or excluded by +'My::Foo::Class::Broken2' + +=head1 Moose::Exception::MethodNameNotFoundInInheritanceHierarchy + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The method 'foo' was not found in the inheritance hierarchy for Foo + +=head1 Moose::Exception::MethodNameNotGiven + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must define a method name to find + +=head1 Moose::Exception::MustDefineAMethodName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must define a method name + +=head1 Moose::Exception::MustDefineAnAttributeName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must define an attribute name + +=head1 Moose::Exception::MustDefineAnOverloadOperator + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Instance>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->instance >> + +This attribute is read-only, isa Object and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::MustHaveAtLeastOneValueToEnumerate + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must have at least one value to enumerate through + +=head1 Moose::Exception::MustPassAHashOfOptions + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a hash of options + +=head1 Moose::Exception::MustPassAMooseMetaRoleInstanceOrSubclass + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a Moose::Meta::Role instance (or a subclass) + +=head1 Moose::Exception::MustPassAPackageNameOrAnExistingClassMOPPackageInstance + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a package name or an existing Class::MOP::Package instance + +=head1 Moose::Exception::MustPassEvenNumberOfArguments + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->args >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an even number of arguments to set + +=head1 Moose::Exception::MustPassEvenNumberOfAttributeOptions + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->options >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an even number of attribute options + +=head1 Moose::Exception::MustProvideANameForTheAttribute + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must provide a name for the attribute + +=head1 Moose::Exception::MustSpecifyAtleastOneMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Must specify at least one method + +=head1 Moose::Exception::MustSpecifyAtleastOneRole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Must specify at least one role + +=head1 Moose::Exception::MustSpecifyAtleastOneRoleToApplicant + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->applicant >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Must specify at least one role to apply to TestClass=HASH(0x2bee290) + Must specify at least one role to apply to Moose::Meta::Class=HASH(0x1a1f818) + Must specify at least one role to apply to Moose::Meta::Role=HASH(0x1f22d40) + +=head1 Moose::Exception::MustSupplyAClassMOPAttributeInstance + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply an attribute which is a 'Class::MOP::Attribute' instance + +=head1 Moose::Exception::MustSupplyADelegateToMethod + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply a delegate_to_method which is a method name or a CODE +reference + +=head1 Moose::Exception::MustSupplyAMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass a metaclass instance if you want to inline + +=head1 Moose::Exception::MustSupplyAMooseMetaAttributeInstance + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply an attribute which is a 'Moose::Meta::Attribute' instance + +=head1 Moose::Exception::MustSupplyAnAccessorTypeToConstructWith + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply an accessor_type to construct with + +=head1 Moose::Exception::MustSupplyAnAttributeToConstructWith + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply an attribute to construct with + +=head1 Moose::Exception::MustSupplyArrayRefAsCurriedArguments + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply a curried_arguments which is an ARRAY reference + +=head1 Moose::Exception::MustSupplyPackageNameAndName + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply the package_name and name parameters + +=head1 Moose::Exception::NeedsTypeConstraintUnionForTypeCoercionUnion + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_coercion_union_object >> + +This attribute is read-only, isa L<Moose::Meta::TypeCoercion::Union> and is +required. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + You can only create a Moose::Meta::TypeCoercion::Union for a +Moose::Meta::TypeConstraint::Union, not a Str + +=head1 Moose::Exception::NeitherAttributeNorAttributeNameIsGiven + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You need to give attribute or attribute_name or both + +=head1 Moose::Exception::NeitherClassNorClassNameIsGiven + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::NeitherRoleNorRoleNameIsGiven + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::NeitherTypeNorTypeNameIsGiven + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::NoAttributeFoundInSuperClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class>, +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Could not find an attribute by the name of 'bar' to inherit from in Test2 + +=head1 Moose::Exception::NoBodyToInitializeInAnAbstractBaseClass + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->package_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + No body to initialize, Class::MOP::Method::Generated is an abstract base +class + +=head1 Moose::Exception::NoCasesMatched + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->cases_to_be_matched >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->to_match >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + No cases matched for 123 + +=head1 Moose::Exception::NoConstraintCheckForTypeConstraint + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + Could not compile type constraint 'FooTypeConstraint' because no constraint +check + +=head1 Moose::Exception::NoDestructorClassSpecified + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The 'inline_destructor' option is present, but no destructor class was +specified + +=head1 Moose::Exception::NoImmutableTraitSpecifiedForClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + no immutable trait specified for Moose::Meta::Class=HASH(0x19a2280) + +=head1 Moose::Exception::NoParentGivenToSubtype + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + A subtype cannot consist solely of a name, it must have a parent + +=head1 Moose::Exception::OnlyInstancesCanBeCloned + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->instance >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You can only clone instances, (ARRAY(0x2162350)) is not a blessed instance + +=head1 Moose::Exception::OperatorIsRequired + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadConflictInSummation + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->overloaded_op >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_application >> + +This attribute is read-only, isa +L<Moose::Meta::Role::Application::RoleSummation> and is required. + +=item B<< $exception->role_names >> + +This attribute is an ArrayRef containing role names, if you want metaobjects +associated with these role names, then call method roles on the exception object. + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadRequiresAMetaClass + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadRequiresAMetaMethod + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadRequiresAMetaOverload + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadRequiresAMethodNameOrCoderef + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadRequiresAnOperator + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverloadRequiresNamesForCoderef + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::OverrideConflictInComposition + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_being_applied_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->two_overrides_found >> + +This attribute is read-only, isa Bool, has a default value 0 and is required. + +=back + +=head4 Sample Error Messages: + + Role 'Foo6' has encountered an 'override' method conflict during composition + (A local method of the same name as been found). This is a fatal error. + Role 'Foo7' has encountered an 'override' method conflict during composition + (Two 'override' methods of the same name encountered). This is a fatal error. + +=head1 Moose::Exception::OverrideConflictInSummation + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_application >> + +This attribute is read-only, isa +L<Moose::Meta::Role::Application::RoleSummation> and is required. + +=item B<< $exception->role_names >> + +This attribute is an ArrayRef containing role names, if you want metaobjects +associated with these role names, then call method roles on the exception object. + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->two_overrides_found >> + +This attribute is read-only, isa Bool, has a default value 0 and is required. + +=back + +=head4 Sample Error Messages: + + Role 'Foo3|Bar3' has encountered an 'override' method conflict during +composition (A local method of the same name has been found). This is a fatal +error. + We have encountered an 'override' method conflict during composition (Two +'override' methods of the same name encountered). This is a fatal error. + +=head1 Moose::Exception::PackageDoesNotUseMooseExporter + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->is_loaded >> + +This attribute is read-only, isa Bool and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->package >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Package in also (NoSuchThing) does not seem to use Moose::Exporter (is it +loaded?) + +=head1 Moose::Exception::PackageNameAndNameParamsNotGivenToWrap + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->code >> + +This attribute is read-only, isa CodeRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply the package_name and name parameters + +=head1 Moose::Exception::PackagesAndModulesAreNotCachable + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->is_module >> + +This attribute is read-only, isa Bool and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Modules are not cacheable + Packages are not cacheable + +=head1 Moose::Exception::ParameterIsNotSubtypeOfParent + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + + +=item B<< $exception->type_parameter >> + +This attribute is read-only, isa Str and is required. + +=back + +=head4 Sample Error Message: + + Int is not a subtype of Float + +=head1 Moose::Exception::ReferencesAreNotAllowedAsDefault + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + References are not allowed as default values, you must wrap the default of +'foo' in a CODE reference (ex: sub { [] } and not []) + +=head1 Moose::Exception::RequiredAttributeLacksInitialization + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + A required attribute must have either 'init_arg', 'builder', or 'default' + +=head1 Moose::Exception::RequiredAttributeNeedsADefault + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You cannot have a required attribute (bar) without a default, builder, or an + init_arg + +=head1 Moose::Exception::RequiredMethodsImportedByClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->imported_method >> + +This attribute is read-only, isa L<Moose::Meta::Role::Method::Required> and is +required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->missing_methods >> + +This attribute is read-only, isa ArrayRef[Moose::Meta::Role::Method::Required] +and is required. + +This attribute has handles as follows: + get_all_methods => elements + get_method_at => get + method_count => count + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + +=head1 Moose::Exception::RequiredMethodsNotImplementedByClass + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::Class> and L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->missing_methods >> + +This attribute is read-only, isa ArrayRef[Moose::Meta::Role::Method::Required] +and is required. + +This attribute has handles as follows: + get_all_methods => elements + get_method_at => get + method_count => count + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + 'Foo3::Role|Bar3::Role|Baz3::Role' requires the method 'foo' to be +implemented by 'My::Foo::Class::Broken3' + +=head1 Moose::Exception::RoleDoesTheExcludedRole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->excluded_role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->second_role_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The role Bar2 does the excluded role 'Bar3' + +=head1 Moose::Exception::RoleExclusionConflict + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->roles >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Messages: + + Conflict detected: Role Foo1 excludes role 'Bar1' + Conflict detected: Roles Foo1, Baz1 exclude role 'Bar1' + +=head1 Moose::Exception::RoleNameRequired + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply a role name to look for + +=head1 Moose::Exception::RoleNameRequiredForMooseMetaRole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply a role name to look for + +=head1 Moose::Exception::RolesDoNotSupportAugment + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Roles cannot support 'augment' + +=head1 Moose::Exception::RolesDoNotSupportExtends + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Roles do not support 'extends' (you can use 'with' to specialize a role) + +=head1 Moose::Exception::RolesDoNotSupportInner + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Roles cannot support 'inner' + +=head1 Moose::Exception::RolesDoNotSupportRegexReferencesForMethodModifiers + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Role>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->modifier_type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->role_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->role_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Roles do not currently support regex references for before method modifiers + +=head1 Moose::Exception::RolesInCreateTakesAnArrayRef + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass an ARRAY ref of roles + +=head1 Moose::Exception::RolesListMustBeInstancesOfMooseMetaRole + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->role >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The list of roles must be instances of Moose::Meta::Role, not foo + +=head1 Moose::Exception::SingleParamsToNewMustBeHashRef + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Single parameters to new() must be a HASH ref + +=head1 Moose::Exception::TriggerMustBeACodeRef + +This class is a subclass of L<Moose::Exception> and consume roles +L<Moose::Exception::Role::InvalidAttributeOptions> and +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Trigger must be a CODE ref on attribute (bar) + +=head1 Moose::Exception::TypeConstraintCannotBeUsedForAParameterizableType + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->parent_type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->parent_type_name ); + + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + The Int[Xyz] constraint cannot be used, because Int doesn't subtype or +coerce from a parameterizable type. + +=head1 Moose::Exception::TypeConstraintIsAlreadyCreated + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->package_defined_in >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Messages: + + The type constraint 'Foo1' has already been created in Moose::Role and +cannot be created again in main + The type constraint 'Foo2' has already been created in Moose and cannot be +created again in main + The type constraint 'Foo3' has already been created in Moose and cannot be +created again in main + +=head1 Moose::Exception::TypeParameterMustBeMooseMetaType + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::TypeConstraint>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_name >> + +This attribute can be used for fetching type +constraint(Moose::Meta::TypeConstraint): + my $type_constraint = Moose::Util::TypeConstraints::find_type_constraint( +$exception->type_name ); + +=back + +=head4 Sample Error Message: + + The type parameter must be a Moose meta type + +=head1 Moose::Exception::UnableToCanonicalizeHandles + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->handles >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Unable to canonicalize the 'handles' option with GLOB(0x109d0b0) + +=head1 Moose::Exception::UnableToCanonicalizeNonRolePackage + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->handles >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Unable to canonicalize the 'handles' option with Foo1 because its metaclass +is not a Moose::Meta::Role + +=head1 Moose::Exception::UnableToRecognizeDelegateMetaclass + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->delegate_metaclass >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Unable to recognize the delegate metaclass 'Class::MOP::Package + +=head1 Moose::Exception::UndefinedHashKeysPassedToMethod + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->hash_keys >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->method_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + Hash keys passed to set must be defined + +=head1 Moose::Exception::UnionCalledWithAnArrayRefAndAdditionalArgs + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->args >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->array >> + +This attribute is read-only, isa ArrayRef and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + union called with an array reference and additional arguments + +=head1 Moose::Exception::UnionTakesAtleastTwoTypeNames + +This class is a subclass of L<Moose::Exception>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must pass in at least 2 type names to make a union + +=head1 Moose::Exception::ValidationFailedForInlineTypeConstraint + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Class>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->class_name >> + +This attribute can be used for fetching metaclass instance: + my $metaclass_instance = Moose::Util::find_meta( $exception->class_name ); + + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->new_member >> + +This attribute is read-only, isa Bool, has a predicate C<is_a_new_member>, has a + default value 0 and is optional. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type_constraint_message >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->value >> + +This attribute is read-only, isa Any and is required. + +=back + +=head4 Sample Error Messages: + + Attribute (foo) does not pass the type constraint because: Validation failed + for 'Int' with value 10.5 + Attribute (a4) does not pass the type constraint because: Validation failed +for 'ArrayRef' with value "invalid" + Attribute (a4) does not pass the type constraint because: Validation failed +for 'ArrayRef' with value "invalid" + Attribute (a4) does not pass the type constraint because: Validation failed +for 'ArrayRef' with value "invalid" + Attribute (a4) does not pass the type constraint because: Validation failed +for 'ArrayRef' with value "invalid" + Attribute (from_parameterizable) does not pass the type constraint because: +Validation failed for 'ParameterizableArrayRef[Int]'\E with value "?Hello"? + A new member value for foo does not pass its type constraint because: +Validation failed for 'Int' with value 1.2 + +=head1 Moose::Exception::ValidationFailedForTypeConstraint + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::Attribute>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute >> + +This attribute is read-only, isa L<Class::MOP::Attribute>, has a predicate +C<is_attribute_set> and is optional. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=item B<< $exception->type >> + +This attribute is read-only, isa L<Moose::Util::TypeConstraints> and is required. + +=item B<< $exception->value >> + +This attribute is read-only, isa Any and is required. + +=back + +=head4 Sample Error Messages: + + Attribute (bar) does not pass the type constraint because: Validation failed + for 'Int' with value "test" + Validation failed for 'OnlyPositiveInts' with value -123 + +=head1 Moose::Exception::WrapTakesACodeRefToBless + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->class >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->code >> + +This attribute is read-only, isa Any and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + You must supply a CODE reference to bless, not (foo) + +=head1 Moose::Exception::WrongTypeConstraintGiven + +This class is a subclass of L<Moose::Exception> and consumes role +L<Moose::Exception::Role::ParamsHash>. + +=over 4 + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item B<< $exception->attribute_name >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->given_type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->message >> + +This attribute is read-only and isa Str. It is lazy and has a default value +'Error'. + +=item B<< $exception->params >> + +This attribute is read-only, isa HashRef and is required. + +=item B<< $exception->required_type >> + +This attribute is read-only, isa Str and is required. + +=item B<< $exception->trace >> + +This attribute is read-only and isa L<Devel::StackTrace>. It is lazy & dependent + on $exception->message. + +=back + +=head4 Sample Error Message: + + The type constraint for foo must be a subtype of ArrayRef but it's a Int + + + +=for comment insert generated content here + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut
\ No newline at end of file diff --git a/lib/Moose/Manual/FAQ.pod b/lib/Moose/Manual/FAQ.pod new file mode 100644 index 0000000..2d6a782 --- /dev/null +++ b/lib/Moose/Manual/FAQ.pod @@ -0,0 +1,470 @@ +# PODNAME: Moose::Manual::FAQ +# ABSTRACT: Frequently asked questions about Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::FAQ - Frequently asked questions about Moose + +=head1 VERSION + +version 2.1405 + +=head1 FREQUENTLY ASKED QUESTIONS + +=head2 Module Stability + +=head3 Is Moose "production ready"? + +Yes! Many sites with household names are using Moose to build +high-traffic services. Countless others are using Moose in production. +See L<http://moose.iinteractive.com/about.html#organizations> for +a partial list. + +As of this writing, Moose is a dependency of several hundred CPAN +modules. L<https://metacpan.org/requires/module/Moose> + +=head3 Is Moose's API stable? + +Yes. The sugary API, the one 95% of users will interact with, is +B<very stable>. Any changes will be B<100% backwards compatible>. + +The meta API is less set in stone. We reserve the right to tweak +parts of it to improve efficiency or consistency. This will not be +done lightly. We do perform deprecation cycles. We I<really> +do not like making ourselves look bad by breaking your code. +Submitting test cases is the best way to ensure that your code is not +inadvertently broken by refactoring. + +=head3 I heard Moose is slow, is this true? + +Again, this one is tricky, so Yes I<and> No. + +Firstly, I<nothing> in life is free, and some Moose features do cost +more than others. It is also the policy of Moose to B<only charge you +for the features you use>, and to do our absolute best to not place +any extra burdens on the execution of your code for features you are +not using. Of course using Moose itself does involve some overhead, +but it is mostly compile time. At this point we do have some options +available for getting the speed you need. + +Currently we provide the option of making your classes immutable as a +means of boosting speed. This will mean a slightly larger compile time +cost, but the runtime speed increase (especially in object +construction) is pretty significant. This can be done with the +following code: + + MyClass->meta->make_immutable(); + +=head2 Constructors + +=head3 How do I write custom constructors with Moose? + +Ideally, you should never write your own C<new> method, and should use +Moose's other features to handle your specific object construction +needs. Here are a few scenarios, and the Moose way to solve them; + +If you need to call initialization code post instance construction, +then use the C<BUILD> method. This feature is taken directly from Perl +6. Every C<BUILD> method in your inheritance chain is called (in the +correct order) immediately after the instance is constructed. This +allows you to ensure that all your superclasses are initialized +properly as well. This is the best approach to take (when possible) +because it makes subclassing your class much easier. + +If you need to affect the constructor's parameters prior to the +instance actually being constructed, you have a number of options. + +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::HTTP_SubtypesAndCoercion> 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? + +Usually the correct approach to subclassing a non-Moose class is +delegation. Moose makes this easy using the C<handles> keyword, +coercions, and C<lazy_build>, so subclassing is often not the ideal +route. + +That said, if you really need to inherit from a non-Moose class, see +L<Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent> for an example of how to do it, +or take a look at L<Moose::Manual::MooseX/"MooseX::NonMoose">. + +=head2 Accessors + +=head3 How do I tell Moose to use get/set accessors? + +The easiest way to accomplish this is to use the C<reader> and +C<writer> attribute options: + + has 'bar' => ( + isa => 'Baz', + reader => 'get_bar', + writer => 'set_bar', + ); + +Moose will still take advantage of type constraints, triggers, etc. +when creating these methods. + +If you do not like this much typing, and wish it to be a default for +your classes, please see L<MooseX::FollowPBP>. This extension will +allow you to write: + + has 'bar' => ( + isa => 'Baz', + is => 'rw', + ); + +Moose will create separate C<get_bar> and C<set_bar> methods instead +of a single C<bar> method. + +If you like C<bar> and C<set_bar>, see +L<MooseX::SemiAffordanceAccessor>. + +NOTE: This B<cannot> be set globally in Moose, as that would break +other classes which are built with Moose. You can still save on typing +by defining a new C<MyApp::Moose> that exports Moose's sugar and then +turns on L<MooseX::FollowPBP>. See +L<Moose::Cookbook::Extending::Mooseish_MooseSugar>. + +=head3 How can I inflate/deflate values in accessors? + +Well, the first question to ask is if you actually need both inflate +and deflate. + +If you only need to inflate, then we suggest using coercions. Here is +some basic sample code for inflating a L<DateTime> object: + + class_type 'DateTime'; + + coerce 'DateTime' + => from 'Str' + => via { DateTime::Format::MySQL->parse_datetime($_) }; + + has 'timestamp' => (is => 'rw', isa => 'DateTime', coerce => 1); + +This creates a custom type for L<DateTime> objects, then attaches +a coercion to that type. The C<timestamp> attribute is then told +to expect a C<DateTime> type, and to try to coerce it. When a C<Str> +type is given to the C<timestamp> accessor, it will attempt to +coerce the value into a C<DateTime> object using the code in found +in the C<via> block. + +For a more comprehensive example of using coercions, see the +L<Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion>. + +If you need to deflate your attribute's value, the current best +practice is to add an C<around> modifier to your accessor: + + # a timestamp which stores as + # seconds from the epoch + has 'timestamp' => (is => 'rw', isa => 'Int'); + + around 'timestamp' => sub { + my $next = shift; + my $self = shift; + + return $self->$next unless @_; + + # assume we get a DateTime object ... + my $timestamp = shift; + return $self->$next( $timestamp->epoch ); + }; + +It is also possible to do deflation using coercion, but this tends to +get quite complex and require many subtypes. An example of this is +outside the scope of this document, ask on #moose or send a mail to +the list. + +Still another option is to write a custom attribute metaclass, which +is also outside the scope of this document, but we would be happy to +explain it on #moose or the mailing list. + +=head2 Method Modifiers + +=head3 How can I affect the values in C<@_> using C<before>? + +You can't, actually: C<before> only runs before the main method, and +it cannot easily affect the method's execution. + +You similarly can't use C<after> to affect the return value of a +method. + +We limit C<before> and C<after> because this lets you write more +concise code. You do not have to worry about passing C<@_> to the +original method, or forwarding its return value (being careful to +preserve context). + +The C<around> method modifier has neither of these limitations, but is +a little more verbose. + +Alternatively, the L<MooseX::Mangle> extension provides the +C<mangle_args> function, which does allow you to affect C<@_>. + +=head3 Can I use C<before> to stop execution of a method? + +Yes, but only if you throw an exception. If this is too drastic a +measure then we suggest using C<around> instead. The C<around> method +modifier is the only modifier which can gracefully prevent execution +of the main method. Here is an example: + + around 'baz' => sub { + my $next = shift; + my ($self, %options) = @_; + unless ($options->{bar} eq 'foo') { + return 'bar'; + } + $self->$next(%options); + }; + +By choosing not to call the C<$next> method, you can stop the +execution of the main method. + +Alternatively, the L<MooseX::Mangle> extension provides the +C<guard> function, which will conditionally prevent execution +of the original method. + +=head3 Why can't I see return values in an C<after> modifier? + +As with the C<before> modifier, the C<after> modifier is simply called +I<after> the main method. It is passed the original contents of C<@_> +and B<not> the return values of the main method. + +Again, the arguments are too lengthy as to why this has to be. And as +with C<before> I recommend using an C<around> modifier instead. Here +is some sample code: + + around 'foo' => sub { + my $next = shift; + my ($self, @args) = @_; + my @rv = $next->($self, @args); + # do something silly with the return values + return reverse @rv; + }; + +Alternatively, the L<MooseX::Mangle> extension provides the +C<mangle_return> function, which allows modifying the return values +of the original method. + +=head2 Type Constraints + +=head3 How can I provide a custom error message for a type constraint? + +Use the C<message> option when building the subtype: + + subtype 'NaturalLessThanTen' + => as 'Natural' + => where { $_ < 10 } + => message { "This number ($_) is not less than ten!" }; + +This C<message> block will be called when a value fails to pass the +C<NaturalLessThanTen> constraint check. + +=head3 Can I turn off type constraint checking? + +There's no support for it in the core of Moose yet. This option may +come in a future release. + +Meanwhile there's a L<MooseX +extension|MooseX::Attribute::TypeConstraint::CustomizeFatal> that +allows you to do this on a per-attribute basis, and if it doesn't do +what you it's easy to write one that fits your use case. + +=head3 My coercions stopped working with recent Moose, why did you break it? + +Moose 0.76 fixed a case where coercions were being applied even if the original +constraint passed. This has caused some edge cases to fail where people were +doing something like + + subtype 'Address', as 'Str'; + coerce 'Address', from 'Str', via { get_address($_) }; + +This is not what they intended, because the type constraint C<Address> is too +loose in this case. It is saying that all strings are Addresses, which is +obviously not the case. The solution is to provide a C<where> clause that +properly restricts the type constraint: + + subtype 'Address', as 'Str', where { looks_like_address($_) }; + +This will allow the coercion to apply only to strings that fail to look like an +Address. + +=head2 Roles + +=head3 Why is BUILD not called for my composed roles? + +C<BUILD> is never called in composed roles. The primary reason is that +roles are B<not> order sensitive. Roles are composed in such a way +that the order of composition does not matter (for information on the +deeper theory of this read the original traits papers here +L<http://www.iam.unibe.ch/~scg/Research/Traits/>). + +Because roles are essentially unordered, it would be impossible to +determine the order in which to execute the C<BUILD> methods. + +As for alternate solutions, there are a couple. + +=over 4 + +=item * + +Using a combination of lazy and default in your attributes to defer +initialization (see the Binary Tree example in the cookbook for a good example +of lazy/default usage +L<Moose::Cookbook::Basics::BinaryTree_AttributeFeatures>) + +=item * + +Use attribute triggers, which fire after an attribute is set, to +facilitate initialization. These are described in the L<Moose> docs, +and examples can be found in the test suite. + +=back + +In general, roles should not I<require> initialization; they should +either provide sane defaults or should be documented as needing +specific initialization. One such way to "document" this is to have a +separate attribute initializer which is required for the role. Here is +an example of how to do this: + + package My::Role; + use Moose::Role; + + has 'height' => ( + is => 'rw', + isa => 'Int', + lazy => 1, + default => sub { + my $self = shift; + $self->init_height; + } + ); + + requires 'init_height'; + +In this example, the role will not compose successfully unless the +class provides a C<init_height> method. + +If none of those solutions work, then it is possible that a role is +not the best tool for the job, and you really should be using +classes. Or, at the very least, you should reduce the amount of +functionality in your role so that it does not require initialization. + +=head3 What are traits, and how are they different from 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, but Perl 6 +will call them roles. + +=head3 Can an attribute-generated method (e.g. an accessor) satisfy requires? + +Yes, just be sure to consume the role I<after> declaring your +attribute. L<Moose::Manual::Roles/Required Attributes> provides +an example: + + package Breakable; + use Moose::Role; + requires 'stress'; + + package Car; + use Moose; + has 'stress' => ( is => 'rw', isa => 'Int' ); + with 'Breakable'; + +If you mistakenly consume the C<Breakable> role before declaring your +C<stress> attribute, you would see an error like this: + + 'Breakable' requires the method 'stress' to be implemented by 'Car' at... + +=head2 Moose and Subroutine Attributes + +=head3 Why don't subroutine attributes I inherited from a superclass work? + +Currently when subclassing a module is done at runtime with the +C<extends> keyword, but attributes are checked at compile time by +Perl. To make attributes work, you must place C<extends> in a C<BEGIN> +block so that the attribute handlers will be available at compile time, +like this: + + BEGIN { extends qw/Foo/ } + +Note that we're talking about Perl's subroutine attributes here, not +Moose attributes: + + sub foo : Bar(27) { ... } + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/MOP.pod b/lib/Moose/Manual/MOP.pod new file mode 100644 index 0000000..9f5ce63 --- /dev/null +++ b/lib/Moose/Manual/MOP.pod @@ -0,0 +1,214 @@ +# PODNAME: Moose::Manual::MOP +# ABSTRACT: The Moose (and Class::MOP) meta API + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::MOP - The Moose (and Class::MOP) meta API + +=head1 VERSION + +version 2.1405 + +=head1 INTRODUCTION + +Moose provides a powerful introspection API built on top of +C<Class::MOP>. "MOP" stands for Meta-Object Protocol. In plainer +English, a MOP is an API for performing introspection on classes, +attributes, methods, and so on. + +In fact, it is C<Class::MOP> that provides many of Moose's core +features, including attributes, before/after/around method modifiers, +and immutability. In most cases, Moose takes an existing C<Class::MOP> +class and subclasses it to add additional features. Moose also adds +some entirely new features of its own, such as roles, the augment +modifier, and types. + +If you're interested in the MOP, it's important to know about +C<Class::MOP> so you know what docs to read. Often, the introspection +method that you're looking for is defined in a C<Class::MOP> class, +rather than Moose itself. + +The MOP provides more than just I<read-only> introspection. It also +lets you add attributes and methods, apply roles, and much more. In +fact, all of the declarative Moose sugar is simply a thin layer on top +of the MOP API. + +If you want to write Moose extensions, you'll need to learn some of +the MOP API. The introspection methods are also handy if you want to +generate docs or inheritance graphs, or do some other runtime +reflection. + +This document is not a complete reference for the meta API. We're just +going to cover some of the highlights, and give you a sense of how it +all works. To really understand it, you'll have to read a lot of other +docs, and possibly even dig into the Moose guts a bit. + +=head1 GETTING STARTED + +The usual entry point to the meta API is through a class's metaclass +object, which is a L<Moose::Meta::Class>. This is available by calling +the C<meta> method on a class or object: + + package User; + + use Moose; + + my $meta = __PACKAGE__->meta; + +The C<meta> method is added to a class when it uses Moose. + +You can also use C<< Class::MOP::Class->initialize($name) >> to get a +metaclass object for any class. This is safer than calling C<< +$class->meta >> when you're not sure that the class has a meta method. + +The C<< Class::MOP::Class->initialize >> constructor will return an +existing metaclass if one has already been created (via Moose or some +other means). If it hasn't, it will return a new C<Class::MOP::Class> +object. This will work for classes that use Moose, meta API classes, +and classes which don't use Moose at all. + +=head1 USING THE METACLASS OBJECT + +The metaclass object can tell you about a class's attributes, methods, +roles, parents, and more. For example, to look at all of the class's +attributes: + + for my $attr ( $meta->get_all_attributes ) { + print $attr->name, "\n"; + } + +The C<get_all_attributes> method is documented in +C<Class::MOP::Class>. For Moose-using classes, it returns a list of +L<Moose::Meta::Attribute> objects for attributes defined in the class +and its parents. + +You can also get a list of methods: + + for my $method ( $meta->get_all_methods ) { + print $method->fully_qualified_name, "\n"; + } + +Now we're looping over a list of L<Moose::Meta::Method> objects. Note +that some of these objects may actually be a subclass of +L<Moose::Meta::Method>, as Moose uses different classes to represent +wrapped methods, delegation methods, constructors, etc. + +We can look at a class's parent classes and subclasses: + + for my $class ( $meta->linearized_isa ) { + print "$class\n"; + } + + for my $subclass ( $meta->subclasses ) { + print "$subclass\n"; + } + +Note that both these methods return class I<names>, not metaclass +objects. + +=head1 ALTERING CLASSES WITH THE MOP + +The metaclass object can change the class directly, by adding +attributes, methods, etc. + +As an example, we can add a method to a class: + + $meta->add_method( 'say' => sub { print @_, "\n" } ); + +Or an attribute: + + $meta->add_attribute( 'size' => ( is => 'rw', isa => 'Int' ) ); + +Obviously, this is much more cumbersome than using Perl syntax or +Moose sugar for defining methods and attributes, but this API allows +for very powerful extensions. + +You might remember that we've talked about making classes immutable +elsewhere in the manual. This is a good practice. However, once a +class is immutable, calling any of these update methods will throw an +exception. + +You can make a class mutable again simply by calling C<< +$meta->make_mutable >>. Once you're done changing it, you can +restore immutability by calling C<< $meta->make_immutable >>. + +However, the most common use for this part of the meta API is as +part of Moose extensions. These extensions should assume that they are +being run before you make a class immutable. + +=head1 GOING FURTHER + +If you're interested in extending Moose, we recommend reading all of +the "Meta" and "Extending" recipes in the L<Moose::Cookbook>. Those +recipes show various practical applications of the MOP. + +If you'd like to write your own extensions, one of the best ways to +learn more about this is to look at other similar extensions to see +how they work. You'll probably also need to read various API docs, +including the docs for the various C<Moose::Meta::*> and +C<Class::MOP::*> classes. + +Finally, we welcome questions on the Moose mailing list and +IRC. Information on the mailing list, IRC, and more references can be +found in the L<Moose.pm docs|Moose/GETTING HELP>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/MethodModifiers.pod b/lib/Moose/Manual/MethodModifiers.pod new file mode 100644 index 0000000..671a250 --- /dev/null +++ b/lib/Moose/Manual/MethodModifiers.pod @@ -0,0 +1,432 @@ +# PODNAME: Moose::Manual::MethodModifiers +# ABSTRACT: Moose's method modifiers + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::MethodModifiers - Moose's method modifiers + +=head1 VERSION + +version 2.1405 + +=head1 WHAT IS A METHOD MODIFIER? + +Moose provides a feature called "method modifiers". You can also think +of these as "hooks" or "advice". + +It's probably easiest to understand this feature with a few examples: + + package Example; + + use Moose; + + sub foo { + print " foo\n"; + } + + before 'foo' => sub { print "about to call foo\n"; }; + after 'foo' => sub { print "just called foo\n"; }; + + around 'foo' => sub { + my $orig = shift; + my $self = shift; + + print " I'm around foo\n"; + + $self->$orig(@_); + + print " I'm still around foo\n"; + }; + +Now if I call C<< Example->new->foo >> I'll get the following output: + + about to call foo + I'm around foo + foo + I'm still around foo + just called foo + +You probably could have figured that out from the names "before", +"after", and "around". + +Also, as you can see, the before modifiers come before around +modifiers, and after modifiers come last. + +When there are multiple modifiers of the same type, the before and +around modifiers run from the last added to the first, and after +modifiers run from first added to last: + + before 2 + before 1 + around 2 + around 1 + primary + around 1 + around 2 + after 1 + after 2 + +=head1 WHY USE THEM? + +Method modifiers have many uses. They are often used in roles to alter the +behavior of methods in the classes that consume the role. See +L<Moose::Manual::Roles> for more information about roles. + +Since modifiers are mostly useful in roles, some of the examples below +are a bit artificial. They're intended to give you an idea of how +modifiers work, but may not be the most natural usage. + +=head1 BEFORE, AFTER, AND AROUND + +Method modifiers can be used to add behavior to methods without modifying the definition of those methods. + +=head2 Before and after Modifiers + +Method modifiers can be used to add behavior to a method that Moose +generates for you, such as an attribute accessor: + + has 'size' => ( is => 'rw' ); + + before 'size' => sub { + my $self = shift; + + if (@_) { + Carp::cluck('Someone is setting size'); + } + }; + +Another use for the before modifier would be to do some sort of +prechecking on a method call. For example: + + before 'size' => sub { + my $self = shift; + + die 'Cannot set size while the person is growing' + if @_ && $self->is_growing; + }; + +This lets us implement logical checks that don't make sense as type +constraints. In particular, they're useful for defining logical rules +about an object's state changes. + +Similarly, an after modifier could be used for logging an action that +was taken. + +Note that the return values of both before and after modifiers are +ignored. + +=head2 Around modifiers + +An around modifier is more powerful than either a before or +after modifier. It can modify the arguments being passed to the +original method, and you can even decide to simply not call the +original method at all. You can also modify the return value with an +around modifier. + +An around modifier receives the original method as its first argument, +I<then> the object, and finally any arguments passed to the method. + + around 'size' => sub { + my $orig = shift; + my $self = shift; + + return $self->$orig() + unless @_; + + my $size = shift; + $size = $size / 2 + if $self->likes_small_things(); + + return $self->$orig($size); + }; + +=head2 Wrapping multiple methods at once + +C<before>, C<after>, and C<around> can also modify multiple methods +at once. The simplest example of this is passing them as a list: + + before [qw(foo bar baz)] => sub { + warn "something is being called!"; + }; + +This will add a C<before> modifier to each of the C<foo>, C<bar>, +and C<baz> methods in the current class, just as though a separate +call to C<before> was made for each of them. The list can be passed +either as a bare list, or as an arrayref. Note that the name of the +function being modified isn't passed in in any way; this syntax is +only intended for cases where the function being modified doesn't +actually matter. If the function name does matter, use something like this: + + for my $func (qw(foo bar baz)) { + before $func => sub { + warn "$func was called!"; + }; + } + +=head2 Using regular expressions to select methods to wrap + +In addition, you can specify a regular expression to indicate the +methods to wrap, like so: + + after qr/^command_/ => sub { + warn "got a command"; + }; + +This will match the regular expression against each method name +returned by L<Class::MOP::Class/get_method_list>, and add a modifier +to each one that matches. The same caveats apply as above. + +Using regular expressions to determine methods to wrap is quite a bit more +powerful than the previous alternatives, but it's also quite a bit more +dangerous. Bear in mind that if your regular expression matches certain Perl +and Moose reserved method names with a special meaning to Moose or Perl, such +as C<meta>, C<new>, C<BUILD>, C<DESTROY>, C<AUTOLOAD>, etc, this could cause +unintended (and hard to debug) problems and is best avoided. + +=head2 Execution order of method modifiers and inheritance + +When both a superclass and an inheriting class have the same method modifiers, +the method modifiers of the inheriting class are wrapped around the method +modifiers of the superclass, as the following example illustrates: + +Here is the parent class: + + package Parent; + use Moose; + sub rant { printf " RANTING!\n" } + before 'rant' => sub { printf " In %s before\n", __PACKAGE__ }; + after 'rant' => sub { printf " In %s after\n", __PACKAGE__ }; + around 'rant' => sub { + my $orig = shift; + my $self = shift; + printf " In %s around before calling original\n", __PACKAGE__; + $self->$orig; + printf " In %s around after calling original\n", __PACKAGE__; + }; + 1; + +And the child class: + + package Child; + use Moose; + extends 'Parent'; + before 'rant' => sub { printf "In %s before\n", __PACKAGE__ }; + after 'rant' => sub { printf "In %s after\n", __PACKAGE__ }; + around 'rant' => sub { + my $orig = shift; + my $self = shift; + printf " In %s around before calling original\n", __PACKAGE__; + $self->$orig; + printf " In %s around after calling original\n", __PACKAGE__; + }; + 1; + +And here's the output when we call the wrapped method (C<< Child->rant >>): + + % perl -MChild -e 'Child->new->rant' + + In Child before + In Child around before calling original + In Parent before + In Parent around before calling original + RANTING! + In Parent around after calling original + In Parent after + In Child around after calling original + In Child after + +=head1 INNER AND AUGMENT + +Augment and inner are two halves of the same feature. The augment +modifier provides a sort of inverted subclassing. You provide part of +the implementation in a superclass, and then document that subclasses +are expected to provide the rest. + +The superclass calls C<inner()>, which then calls the C<augment> +modifier in the subclass: + + package Document; + + use Moose; + + sub as_xml { + my $self = shift; + + my $xml = "<document>\n"; + $xml .= inner(); + $xml .= "</document>\n"; + + return $xml; + } + +Using C<inner()> in this method makes it possible for one or more +subclasses to then augment this method with their own specific +implementation: + + package Report; + + use Moose; + + extends 'Document'; + + augment 'as_xml' => sub { + my $self = shift; + + my $xml = " <report>\n"; + $xml .= inner(); + $xml .= " </report>\n"; + + return $xml; + }; + +When we call C<as_xml> on a Report object, we get something like this: + + <document> + <report> + </report> + </document> + +But we also called C<inner()> in C<Report>, so we can continue +subclassing and adding more content inside the document: + + package Report::IncomeAndExpenses; + + use Moose; + + extends 'Report'; + + augment 'as_xml' => sub { + my $self = shift; + + my $xml = ' <income>' . $self->income . '</income>'; + $xml .= "\n"; + $xml .= ' <expenses>' . $self->expenses . '</expenses>'; + $xml .= "\n"; + + $xml .= inner() || q{}; + + return $xml; + }; + +Now our report has some content: + + <document> + <report> + <income>$10</income> + <expenses>$8</expenses> + </report> + </document> + +What makes this combination of C<augment> and C<inner()> special is +that it allows us to have methods which are called from parent (least +specific) to child (most specific). This inverts the normal +inheritance pattern. + +Note that in C<Report::IncomeAndExpenses> we call C<inner()> again. If the +object is an instance of C<Report::IncomeAndExpenses> then this call is a +no-op, and just returns false. It's a good idea to always call C<inner()> to +allow for future subclassing. + +=head1 OVERRIDE AND SUPER + +Finally, Moose provides some simple sugar for Perl's built-in method +overriding scheme. If you want to override a method from a parent +class, you can do this with C<override>: + + package Employee; + + use Moose; + + extends 'Person'; + + has 'job_title' => ( is => 'rw' ); + + override 'display_name' => sub { + my $self = shift; + + return super() . q{, } . $self->title(); + }; + +The call to C<super()> is almost the same as calling C<< +$self->SUPER::display_name >>. The difference is that the arguments +passed to the superclass's method will always be the same as the ones +passed to the method modifier, and cannot be changed. + +All arguments passed to C<super()> are ignored, as are any changes +made to C<@_> before C<super()> is called. + +=head1 SEMI-COLONS + +Because all of these method modifiers are implemented as Perl +functions, you must always end the modifier declaration with a +semi-colon: + + after 'foo' => sub { }; + +=head1 CAVEATS + +These method modification features do not work well with multiple inheritance, +due to how method resolution is performed in Perl. Experiment with a test +program to ensure your class hierarchy works as expected, or more preferably, +don't use multiple inheritance (roles can help with this)! + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/MooseX.pod b/lib/Moose/Manual/MooseX.pod new file mode 100644 index 0000000..8748267 --- /dev/null +++ b/lib/Moose/Manual/MooseX.pod @@ -0,0 +1,326 @@ +# PODNAME: Moose::Manual::MooseX +# ABSTRACT: Recommended Moose extensions + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::MooseX - Recommended Moose extensions + +=head1 VERSION + +version 2.1405 + +=head1 MooseX? + +It's easy to extend and change Moose, and this is part of what makes +Moose so powerful. You can use the MOP API to do things your own way, +add new features, and generally customize your Moose. + +Writing your own extensions does require a good understanding of the +meta-model. You can start learning about this with the +L<Moose::Manual::MOP> docs. There are also several extension recipes +in the L<Moose::Cookbook>. + +Explaining how to write extensions is beyond the scope of this +manual. Fortunately, lots of people have already written extensions +and put them on CPAN for you. + +This document covers a few of the ones we like best. + +=head1 L<MooseX::AttributeHelpers> + +The functionality of this MooseX module has been moved into Moose core. +See L<Moose::Meta::Attribute::Native>. + +=head1 L<Moose::Autobox> + +MooseX::AttributeHelpers, but turned inside out, Moose::Autobox provides +methods on both arrays/hashes/etc. but also references to them, using +Moose roles, allowing you do to things like: + + use Moose::Autobox; + + $somebody_elses_object->orders->push($order); + +Lexically scoped and not to everybody's taste, but very handy for sugaring +up other people's APIs and your own code. + +=head1 L<MooseX::StrictConstructor> + +By default, Moose lets you pass any old junk into a class's +constructor. If you load L<MooseX::StrictConstructor>, your class will +throw an error if it sees something it doesn't recognize; + + package User; + + use Moose; + use MooseX::StrictConstructor; + + has 'name'; + has 'email'; + + User->new( name => 'Bob', emali => 'bob@example.com' ); + +With L<MooseX::StrictConstructor>, that typo ("emali") will cause a +runtime error. With plain old Moose, the "emali" attribute would be +silently ignored. + +=head1 L<MooseX::Params::Validate> + +We have high hopes for the future of L<MooseX::Method::Signatures> and +L<Moops>. However, these modules, while used regularly in +production by some of the more insane members of the community, are +still marked alpha just in case backwards incompatible changes need to +be made. + +If you don't want to risk that, for now we recommend the decidedly more +clunky (but also faster and simpler) L<MooseX::Params::Validate>. This +module lets you apply Moose types and coercions to any method +arguments. + + package User; + + use Moose; + use MooseX::Params::Validate; + + sub login { + my $self = shift; + my ($password) + = validated_list( \@_, password => { isa => 'Str', required => 1 } ); + + ... + } + +=head1 L<MooseX::Getopt> + +This is a role which adds a C<new_with_options> method to your +class. This is a constructor that takes the command line options and +uses them to populate attributes. + +This makes writing a command-line application as a module trivially +simple: + + package App::Foo; + + use Moose; + with 'MooseX::Getopt'; + + has 'input' => ( + is => 'ro', + isa => 'Str', + required => 1 + ); + + has 'output' => ( + is => 'ro', + isa => 'Str', + required => 1 + ); + + sub run { ... } + +Then in the script that gets run we have: + + use App::Foo; + + App::Foo->new_with_options->run; + +From the command line, someone can execute the script: + + foo@example> foo --input /path/to/input --output /path/to/output + +=head1 L<MooseX::Singleton> + +To be honest, using a singleton is just a way to have a magic global +variable in languages that don't actually have global variables. + +In perl, you can just as easily use a global. However, if your +colleagues are Java-infected, they might prefer a singleton. Also, if +you have an existing class that I<isn't> a singleton but should be, +using L<MooseX::Singleton> is the easiest way to convert it. + + package Config; + + use MooseX::Singleton; # instead of Moose + + has 'cache_dir' => ( ... ); + +It's that simple. + +=head1 EXTENSIONS TO CONSIDER + +There are literally dozens of other extensions on CPAN. This is a list +of extensions that you might find useful, but we're not quite ready to +endorse just yet. + +=head2 L<MooseX::Declare> + +MooseX::Declare is based on L<Devel::Declare>, a giant bag of crack +originally implemented by mst with the goal of upsetting the perl core +developers so much by its very existence that they implemented proper +keyword handling in the core. + +As of perl5 version 14, this goal has been achieved, and modules such +as L<Devel::CallParser>, L<Function::Parameters>, and L<Keyword::Simple> provide +mechanisms to mangle perl syntax that don't require hallucinogenic +drugs to interpret the error messages they produce. + +If you want to use declarative syntax in new code, please for the love +of kittens get yourself a recent perl and look at L<Moops> instead. + +=head2 L<MooseX::Types> + +This extension helps you build a type library for your application. It +also lets you predeclare type names and use them as barewords. + + use MooseX::Types -declare => ['PositiveInt']; + use MooseX::Types::Moose 'Int'; + + subtype PositiveInt, + as Int, + where { $_ > 0 }, + message { "Int is not larger than 0" }; + +One nice feature is that those bareword names are actually namespaced +in Moose's type registry, so multiple applications can use the same +bareword names, even if the type definitions differ. + +=head2 L<MooseX::Types::Structured> + +This extension builds on top of L<MooseX::Types> to let you declare +complex data structure types. + + use MooseX::Types -declare => [ qw( Name Color ) ]; + use MooseX::Types::Moose qw(Str Int); + use MooseX::Types::Structured qw(Dict Tuple Optional); + + subtype Name + => as Dict[ first => Str, middle => Optional[Str], last => Str ]; + + subtype Color + => as Tuple[ Int, Int, Int, Optional[Int] ]; + +Of course, you could always use objects to represent these sorts of +things too. + +=head2 L<MooseX::ClassAttribute> + +This extension provides class attributes for Moose classes. The +declared class attributes are introspectable just like regular Moose +attributes. + + package User; + + use Moose; + use MooseX::ClassAttribute; + + has 'name' => ( ... ); + + class_has 'Cache' => ( ... ); + +Note however that this class attribute does I<not> inherit like a +L<Class::Data::Inheritable> or similar attribute - calling + + $subclass->Cache($cache); + +will set it for the superclass as well. Additionally, class data is usually +The Wrong Thing To Do in a strongly OO program since it makes testing a +lot harder - consider carefully whether you'd be better off with an object +that's passed around instead. + +=head2 L<MooseX::Daemonize> + +This is a role that provides a number of methods useful for creating a +daemon, including methods for starting and stopping, managing a PID +file, and signal handling. + +=head2 L<MooseX::Role::Parameterized> + +If you find yourself wanting a role that customizes itself for each +consumer, this is the tool for you. With this module, you can create a +role that accepts parameters and generates attributes, methods, etc. on +a customized basis for each consumer. + +=head2 L<MooseX::POE> + +This is a small wrapper that ties together a Moose class with +C<POE::Session>, and gives you an C<event> sugar function to declare +event handlers. + +=head2 L<MooseX::FollowPBP> + +Automatically names all accessors I<Perl Best Practices>-style, +"get_size" and "set_size". + +=head2 L<MooseX::SemiAffordanceAccessor> + +Automatically names all accessors with an explicit set and implicit +get, "size" and "set_size". + +=head2 L<MooseX::NonMoose> + +MooseX::NonMoose allows for easily subclassing non-Moose classes with Moose, +taking care of the annoying details connected with doing this, such as +setting up proper inheritance from Moose::Object and installing +(and inlining, at make_immutable time) a constructor that makes sure things +like BUILD methods are called. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Resources.pod b/lib/Moose/Manual/Resources.pod new file mode 100644 index 0000000..e122455 --- /dev/null +++ b/lib/Moose/Manual/Resources.pod @@ -0,0 +1,515 @@ +# PODNAME: Moose::Manual::Resources +# ABSTRACT: Links to various tutorials, videos, blogs, presentations, interviews, etc... + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Resources - Links to various tutorials, videos, blogs, presentations, interviews, etc... + +=head1 VERSION + +version 2.1405 + +=head1 Resources + +This section is an attempt to collect and list some of the many Moose resources that can be found online. Additional information can be found at http://moose.perl.org/ + +=head2 Videos + +=over 4 + +=item + +A new object system for the Perl 5 core, Stevan Little +L<https://www.youtube.com/watch?v=Gf0O6Ct7V1s> + +=item + +Stevan Little interviewed by Gabor Szabo for PerlMaven.com +L<https://www.youtube.com/watch?v=shu-bVimOpM> + +=item + +Perl 6 OO vs. Moose, Herbert Breunung +L<https://www.youtube.com/watch?v=Boh3109HVLo> + +=item + +Introduction To Moose, Mike Whitaker +L<https://www.youtube.com/watch?v=YVtqa6zWXqY> + +=item + +"Dr. Strange... Moose or: How I Learned to Stop Worrying and Love Perl" +L<https://www.youtube.com/watch?v=PNFiIU8S-7g> + +=item + +Evolving Software with Moose, Dave Cross +L<https://www.youtube.com/watch?v=BIMREkoPYKA> + +=item + +Testing with Test::Class::Moose, Curtis Poe +L<https://www.youtube.com/watch?v=kUHI1iRrfF4> + +=item + +"Moose is Perl" tutorial, OSCON 2014, Ricardo Signes +L<https://www.youtube.com/watch?v=LKXvG6VKew4> + +=back + +=head2 Articles + +=over 4 + +=item + +Perl.org Moose Whitepaper +L<https://www.perl.org/about/whitepapers/perl-object-oriented.html> + +=item + +PerlMaven.com +L<http://perlmaven.com/moose> + +=item + +Getting Started with Moose, brian d foy +http://www.theperlreview.com/articles/moose.html + +=item + +Wikipedia.org +L<http://en.wikipedia.org/wiki/Moose_(Perl)> + +=item + +Moose: A postmodern object system for Perl 5 +L<http://perltraining.com.au/tips/2010-01-27.html> + +=item + +Roles and Delegates and Refactoring +L<http://blog.woobling.org/2009/10/roles-and-delegates-and-refactoring.html> + +=back + +=head1 Older Resources + +=head2 Articles + +=head3 2011 + +=over 4 + +=item + +Dave Rolsky reviews Perl Best Practices, Chapter 15, Objects 7 years later +L<http://blog.urth.org/2011/03/reviewing-perl-best-practices-chapter-15-objects.html> + +=item + +Mark A. Stratman discusses subclassing non-Moose classes +L<http://blogs.perl.org/users/mark_a_stratman/2011/03/subclassing-tricky-non-moose-classes-constructor-problems.html> + +=item + +Mark A. Stratman shows how to use delegation to work with non-Moose classes +L<http://blogs.perl.org/users/mark_a_stratman/2011/03/subclassing-tricky-non-moose-classes-dont-do-it.html> + +=item + +The WebGUI folks talk about version 8.0 (which uses Moose) +L<http://blogs.perl.org/users/preaction/2011/01/whats-new-in-webgui-80-1---psgiplack.html> + +=item + +chromatic discusses Parameterized roles with Moose +L<http://www.modernperlbooks.com/mt/2011/01/the-parametric-role-of-my-mvc-plugin-system.html> + +=back + +=head3 2010 + +=over 4 + +=item + +Chris Prather discusses Moose and the Modern Perl movement +L<http://chris.prather.org/been-there-done-that.md.html> + +=item + +Devin Austin talks about MooseX::App::Cmd +L<http://www.catalyzed.org/2010/04/moosexappcmd-and-your-command-line-apps.html> + +=item + +JT Smith declares The Second Age of Perl +L<http://blogs.perl.org/users/jt_smith/2010/04/the-second-age-of-perl.html> + +=item + +JT Smith talks about Lacuna Expanse (which uses Moose) +L<http://blogs.perl.org/users/jt_smith/2010/10/why-the-lacuna-expanse-is-good-for-perl.html> + +=item + +Moose 1.00 is Released +L<http://stevan-little.blogspot.com/2010/03/moose-100-is-released.html> + +=item + +Moritz Lenz asks What is "Modern Perl"? +L<http://perlgeek.de/blog-en/perl-tips/what-is-modern-perl.html> + +=item + +Yuval Kogman declares "Moose has won". +L<http://blog.woobling.org/2010/09/moose-has-won.html> + +=item + +chromatic discusses how Moose helps you write more correct code +L<http://www.modernperlbooks.com/mt/2010/01/subtle-encouragement-toward-correctness.html> + +=item + +chromatic discusses the Moose deprecation policy +L<http://www.modernperlbooks.com/mt/2010/09/the-right-approach-to-deprecation.html> + +=item + +chromatic talks about Class::MOP in relation to his Modern Perl book +L<http://www.modernperlbooks.com/mt/2010/03/ill-get-the-mop.html> + +=item + +chromatic talks about Encapsulation and Moose +L<http://www.modernperlbooks.com/mt/2010/09/what-you-can-and-cannot-teach-about-encapsulation.html> + +=back + +=head3 2009 + +=over 4 + +=item + +Bruno Vecchi praises Moose for making his protein analysis code easier +L<http://zerothorder.blogspot.com/2009/04/chopping-proteins-with-moose.html> + +=item + +Chris Prather compares MooseX::Declare to Simula 67 +L<http://chris.prather.org/a-little-bit-of-history.md.html> + +=item + +Chris Prather rationalizes Moose's "post modern" label +L<http://chris.prather.org/why-moose-is-post-modern.html> + +=item + +Dave Rolsky's post-mortem on his Moose documentation grant +L<http://blog.urth.org/2009/04/moose-docs-grant-wrap-up.html> + +=item + +David McLaughlin experiments with extending Moose for MooseX::ChainedAccessors +L<http://www.dmclaughlin.com/2009/05/15/chained-accessors-in-moose/> + +=item + +Sam Crawley summarizes his experience with roles +L<http://samcrawley.wordpress.com/2009/05/03/getting-the-hang-of-moose-roles/> + +=item + +Shawn M Moore discusses Perl::Critic for Moose and linting with the MOP +L<http://blog.sartak.org/2009/05/perl-critic-dynamic-moose.html> + +=item + +Shlomi Fish discovers a better way to Moose +L<http://community.livejournal.com/shlomif_tech/38407.html> + +=item + +Stevan Little explains why you should make your Moose classes immutable +L<http://stevan-little.blogspot.com/2009/06/why-makeimmutable-is-recommended-for_13.html> + +=item + +Tomas Doran interview about the new Moose-based Catalyst +L<http://www.catalyzed.org/2009/04/catalyst-58-released.html> + +=item + +chromatic contrasts roles and duck-typing +L<http://www.modernperlbooks.com/mt/2009/05/perl-roles-versus-duck-typing.html> + +=item + +chromatic contrasts roles and inheritance +L<http://www.modernperlbooks.com/mt/2009/05/perl-roles-versus-inheritance.html> + +=item + +chromatic on The Why of Perl Roles +L<http://www.modernperlbooks.com/mt/2009/04/the-why-of-perl-roles.html> + +=back + +=head3 2008 + +=over 4 + +=item + +Barry Walsh does an excellent comparison of Moose and Ruby (specifically the Doodle module) +L<http://draegtun.wordpress.com/2008/03/12/doodling-with-moose-part-1/> + +=item + +Tim Bunce's excellent Perl Myths talk gives a shout out to Moose +L<http://www.slideshare.net/Tim.Bunce/perl-myths-200802-with-notes/> + +=item + +chromatic suggests Moose and Mouse in his Beginners Introduction to Object-Oriented Programming with Perl article +L<http://broadcast.oreilly.com/2008/11/beginners-introduction-to-obje.html> + +=back + +=head3 2007 + +=over 4 + +=item + +Larry mentioned Moose in 2007's State of the Onion speech +L<http://www.perl.com/pub/a/2007/12/06/soto-11.html?page=3> + +=item + +Max Kanat-Alexander (of Bugzilla fame) has some nice things to say about Moose +L<http://avatraxiom.livejournal.com/70947.html> + +=back + +=head3 2006 + +=over 4 + +=item + +Class::MOP Review (OnLAMP) +L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html> + +=back + +=head2 Presentations + +=head3 Perl Mongers Groups + +=over 4 + +=item + +Doug Treder's Moose talk at Seattle Perl Users Group +L<http://www.slideshare.net/dtreder/moose-527243> + +=item + +Hans Dieter Pearcey's Meta-Moose at PDX.pm +L<http://www.weftsoar.net/~hdp/talk/meta-moose/slides/start.html> + +=item + +Piers Cawley's MooseX::Declare talk at London.pm (video) +L<http://www.bofh.org.uk/2009/05/13/london-pm-presentation> + +=item + +Robert Boone's Moose talk at Houston.pm +L<http://houston.pm.org/talks/2007talks/0704Talk/slides/start.html> + +=item + +hakobe's Moose presentation at Kansai.pm +L<http://www.slideshare.net/hakobe/moose> + +=back + +=head3 2011 + +=over 4 + +=item + +SawyerX's FOSDEM 2011 Moose talk +L<http://www.slideshare.net/xSawyer/moose-talk-at-fosdem-2011-perl-devroom> + +=back + +=head3 2010 + +=over 4 + +=item + +Drew Stephens gives a lighting talk on Moose at SHDH 36 +L<http://www.slideshare.net/dinomite/learning-moose-lightning> + +=item + +Jesse Luehrs's "Extending Moose" talk at YAPC::NA 2010 +L<http://tozt.net/talks/extending_moose_yapc_na_2010/> + +=item + +Shawn Moore's "Non-hierarchical osdc.tw +L<http://sartak.org/talks/osdc.tw-2010/nonhierarchical-oop/nonhierarchical-oop.pdf> + +=item + +Ynon Perek's Perl Object Oriented Programming slides +L<http://prezi.com/fgdoyw0smyqo/perl-object-oriented-programming/> + +=back + +=head3 2009 + +=over 4 + +=item + +Dave Rolsky's Introduction to Moose master class at YAPC::NA 2009 (delivered by Shawn Moore and Jonathan Rockway) +L<http://yapc10.org/yn2009/talk/2047> + +=item + +Devin Austin's Intro to Moose at YAPC::NA 2009 +L<http://yapc10.org/yn2009/talk/1967> + +=item + +Hans Dieter Pearcey's Code Reuse with Moose at YAPC::NA 2009 +L<http://yapc10.org/yn2009/talk/1984> + +=item + +Mike Whitaker's Intro to Moose at Italian Perl Workshop +L<http://www.slideshare.net/Penfold/introduction-to-moose-2437037> + +=item + +Mike Whitaker's Introduction to Moose at the Italian Perl Workshop +L<http://conferences.yapceurope.org/ipw2009/talk/2371> + +=item + +Shawn M Moore's Intro to Moose at Frozen Perl +L<http://sartak.org/talks/frozen-perl-2009/moose/> + +=item + +Shawn Moore's Extending Moose for Applications at YAPC::NA 2009 +L<http://sartak.org/talks/yapc-na-2009/extending-moose/extending-moose.pdf> + +=item + +Shawn Moore's Moose master class at YAPC::Asia 2009 +L<http://conferences.yapcasia.org/ya2009/talk/2192> + +=item + +Yuval Kogman's Why Moose at the Nordic Perl Workshop +L<http://www.perlworkshop.no/npw2009/talk/1901> + +=back + +=head3 2008 + +=over 4 + +=item + +Mike Whitaker's Intro to Moose at the London Perl Workshop +L<http://yapc.tv/2008/lpw/mike-whitaker-intro-moose/> + +=back + +=head3 2006 + +=over 4 + +=item + +Sam Vilain gives the very first Moose talk at YAPC::EU +L<http://www.yapceurope.org/2006/talk/item/63.html> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Roles.pod b/lib/Moose/Manual/Roles.pod new file mode 100644 index 0000000..3000e39 --- /dev/null +++ b/lib/Moose/Manual/Roles.pod @@ -0,0 +1,422 @@ +# PODNAME: Moose::Manual::Roles +# ABSTRACT: Roles, an alternative to deep hierarchies and base classes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Roles - Roles, an alternative to deep hierarchies and base classes + +=head1 VERSION + +version 2.1405 + +=head1 WHAT IS A ROLE? + +A role encapsulates some piece of behavior or state that can be shared between +classes. It is something that classes I<do>. It is important to understand that +I<roles are not classes>. You cannot inherit from a role, and a role cannot be +instantiated. We sometimes say that roles are I<consumed>, either by classes +or other roles. + +Instead, a role is I<composed> into a class. In practical terms, this +means that all of the methods, method modifiers, and attributes defined in a role are +added directly to (we sometimes say "flattened into") the class that +consumes the role. These attributes and methods then appear as if they +were defined in the class itself. A subclass of the consuming class +will inherit all of these methods and attributes. + +Moose roles are similar to mixins or interfaces in other languages. + +Besides defining their own methods and attributes, roles can also +require that the consuming class define certain methods of its +own. You could have a role that consisted only of a list of required +methods, in which case the role would be very much like a Java +interface. + +Note that attribute accessors also count as methods for the +purposes of satisfying the requirements of a role. + +=head1 A SIMPLE ROLE + +Creating a role looks a lot like creating a Moose class: + + package Breakable; + + use Moose::Role; + + has 'is_broken' => ( + is => 'rw', + isa => 'Bool', + ); + + sub break { + my $self = shift; + + print "I broke\n"; + + $self->is_broken(1); + } + +Except for our use of L<Moose::Role>, this looks just like a class +definition with Moose. However, this is not a class, and it cannot be +instantiated. + +Instead, its attributes and methods will be composed into classes +which use the role: + + package Car; + + use Moose; + + with 'Breakable'; + + has 'engine' => ( + is => 'ro', + isa => 'Engine', + ); + +The C<with> function composes roles into a class. Once that is done, +the C<Car> class has an C<is_broken> attribute and a C<break> +method. The C<Car> class also C<does('Breakable')>: + + my $car = Car->new( engine => Engine->new ); + + print $car->is_broken ? 'Busted' : 'Still working'; + $car->break; + print $car->is_broken ? 'Busted' : 'Still working'; + + $car->does('Breakable'); # true + +This prints: + + Still working + I broke + Busted + +We could use this same role in a C<Bone> class: + + package Bone; + + use Moose; + + with 'Breakable'; + + has 'marrow' => ( + is => 'ro', + isa => 'Marrow', + ); + +See also L<Moose::Cookbook::Roles::Comparable_CodeReuse> for an example. + +It's possible to compose existing roles into new roles. For example, we can +have a C<HandleWithCare> class which applies both the C<Breakable> and +C<Package> roles to any class which consumes it: + + package HandleWithCare; + + use Moose::Role; + + with 'Breakable', 'Package'; + +=head1 REQUIRED METHODS + +As mentioned previously, a role can require that consuming classes +provide one or more methods. Using our C<Breakable> example, let's +make it require that consuming classes implement their own C<break> +methods: + + package Breakable; + + use Moose::Role; + + requires 'break'; + + has 'is_broken' => ( + is => 'rw', + isa => 'Bool', + ); + + after 'break' => sub { + my $self = shift; + + $self->is_broken(1); + }; + +If we try to consume this role in a class that does not have a +C<break> method, we will get an exception. + +You can see that we added a method modifier on C<break>. We want +classes that consume this role to implement their own logic for +breaking, but we make sure that the C<is_broken> attribute is always +set to true when C<break> is called. + + package Car + + use Moose; + + with 'Breakable'; + + has 'engine' => ( + is => 'ro', + isa => 'Engine', + ); + + sub break { + my $self = shift; + + if ( $self->is_moving ) { + $self->stop; + } + } + +=head2 Roles Versus Abstract Base Classes + +If you are familiar with the concept of abstract base classes in other +languages, you may be tempted to use roles in the same way. + +You I<can> define an "interface-only" role, one that contains I<just> +a list of required methods. + +However, any class which consumes this role must implement all of the +required methods, either directly or through inheritance from a +parent. You cannot delay the method requirement check so that they can +be implemented by future subclasses. + +Because the role defines the required methods directly, adding a base +class to the mix would not achieve anything. We recommend that you +simply consume the interface role in each class which implements that +interface. + +=head2 Required Attributes + +As mentioned before, a role's required method may also be satisfied by an +attribute accessor. However, the call to C<has> which defines an attribute +happens at runtime. This means that you must define the attribute I<before> +consuming the role, or else the role will not see the generated accessor. + + package Breakable; + + use Moose::Role; + + requires 'stress'; + + package Car; + + use Moose; + + has 'stress' => ( + is => 'rw', + isa => 'Int', + ); + + with 'Breakable'; + +=head1 USING METHOD MODIFIERS + +Method modifiers and roles are a very powerful combination. Often, a +role will combine method modifiers and required methods. We already +saw one example with our C<Breakable> example. + +Method modifiers increase the complexity of roles, because they make +the role application order relevant. If a class uses multiple roles, +each of which modify the same method, those modifiers will be applied +in the same order as the roles are used: + + package MovieCar; + + use Moose; + + extends 'Car'; + + with 'Breakable', 'ExplodesOnBreakage'; + +Assuming that the new C<ExplodesOnBreakage> role I<also> has an +C<after> modifier on C<break>, the C<after> modifiers will run one +after the other. The modifier from C<Breakable> will run first, then +the one from C<ExplodesOnBreakage>. + +=head1 METHOD CONFLICTS + +If a class composes multiple roles, and those roles have methods of +the same name, we will have a conflict. In that case, the composing +class is required to provide its I<own> method of the same name. + + package Breakdancer; + + use Moose::Role; + + sub break { + + } + +If we compose both C<Breakable> and C<Breakdancer> in a class, we must +provide our own C<break> method: + + package FragileDancer; + + use Moose; + + with 'Breakable', 'Breakdancer'; + + sub break { ... } + +A role can be a collection of other roles: + + package Break::Bundle; + + use Moose::Role; + + with ('Breakable', 'Breakdancer'); + +When a role consumes another a role, the I<consuming> role's methods silently +win in any conflict, and the consumed role's methods are simply ignored. + +=head1 METHOD EXCLUSION AND ALIASING + +If we want our C<FragileDancer> class to be able to call the methods +from both its roles, we can alias the methods: + + package FragileDancer; + + use Moose; + + with 'Breakable' => { -alias => { break => 'break_bone' } }, + 'Breakdancer' => { -alias => { break => 'break_dance' } }; + +However, aliasing a method simply makes a I<copy> of the method with +the new name. We also need to exclude the original name: + + with 'Breakable' => { + -alias => { break => 'break_bone' }, + -excludes => 'break', + }, + 'Breakdancer' => { + -alias => { break => 'break_dance' }, + -excludes => 'break', + }; + +The excludes parameter prevents the C<break> method from being composed +into the C<FragileDancer> class, so we don't have a conflict. This +means that C<FragileDancer> does not need to implement its own +C<break> method. + +This is useful, but it's worth noting that this breaks the contract +implicit in consuming a role. Our C<FragileDancer> class does both the +C<Breakable> and C<BreakDancer>, but does not provide a C<break> +method. If some API expects an object that does one of those roles, it +probably expects it to implement that method. + +In some use cases we might alias and exclude methods from roles, but +then provide a method of the same name in the class itself. + +Also see L<Moose::Cookbook::Roles::Restartable_AdvancedComposition> for an example. + +=head1 OVERLOADING + +When a Moose role uses overloading, that overloading is composed into any +classes that consume the role. This includes the setting of the C<fallback> +value for that role's overloading. Just as with methods and attributes, when a +role consumes another role, that other role's overloading settings are applied +to the role. + +Just as with methods, there can be conflicts with overloading implementations +between multiple roles when they are all consumed by a class. If two roles +both provide different overloading implementations for a given operator, that +is a conflict. If two roles both implement overloading and have different +C<fallback> values, that is also considered a conflict. These conflicts are +detected when multiple roles are being composed into a class together. + +When a role consumes another role, the consuming role's overloading fallback +and operator implementations silently "win" the conflict. + +=head1 ROLE EXCLUSION + +A role can say that it cannot be combined with some other role. This +should be used with great caution, since it limits the re-usability of +the role. + + package Breakable; + + use Moose::Role; + + excludes 'BreakDancer'; + +=head1 ADDING A ROLE TO AN OBJECT INSTANCE + +You may want to add a role to an object instance, rather than to a class. For +example, you may want to add debug tracing to one instance of an object while +debugging a particular bug. Another use case might be to dynamically change +objects based on a user's configuration, as a plugin system. + +The best way to do this is to use the C<apply_all_roles()> function from +L<Moose::Util>: + + use Moose::Util qw( apply_all_roles ); + + my $car = Car->new; + apply_all_roles( $car, 'Breakable' ); + +This function can apply more than one role at a time, and will do so using the +normal Moose role combination system. We recommend using this function to +apply roles to an object. This is what Moose uses internally when you call +C<with>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Support.pod b/lib/Moose/Manual/Support.pod new file mode 100644 index 0000000..d4d48a6 --- /dev/null +++ b/lib/Moose/Manual/Support.pod @@ -0,0 +1,204 @@ +# PODNAME: Moose::Manual::Support +# ABSTRACT: Policies regarding support, releases, and compatibility. + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Support - Policies regarding support, releases, and compatibility. + +=head1 VERSION + +version 2.1405 + +=head1 SUPPORT POLICY + +There are two principles to Moose's policy of supported behavior. + +=over 4 + +=item 1. + +Moose favors correctness over everything. + +=item 2. + +Moose supports documented and tested behavior, not accidental behavior or side +effects. + +=back + +If a behavior has never been documented or tested, the behavior is +I<officially> undefined. Relying upon undocumented and untested behavior is +done at your own risk. + +If a behavior is documented or tested but found to be incorrect later, the +behavior will go through a deprecation period. During the deprecation period, +use of that feature will cause a warning. Eventually, the deprecated feature +will be removed. + +In some cases, it is not possible to deprecate a behavior. In this case, the +behavior will simply be changed in a major release. + +=head1 RELEASE SCHEDULE + +Moose is on a system of quarterly major releases, with minor releases as +needed between major releases. A minor release is defined as one that makes +every attempt to preserve backwards compatibility. Currently this means that we +did not introduce any new dependency conflicts, and that we did not make any +changes to documented or tested behavior (this typically means that minor +releases will not change any existing tests in the test suite, although they +can add new ones). A minor release can include new features and bug fixes. + +Major releases may be backwards incompatible. Moose prioritizes +correctness over backwards compatibility or performance; see the L<DEPRECATION +POLICY> to understand how backwards incompatible changes are announced. + +Major releases are scheduled to happen during fixed release windows. If the +window is missed, then there will not be a major release until the next +release window. The release windows are one month long, and occur during the +months of January, April, July, and October. + +Before a major release, a series of development releases will be made so that +users can test the upcoming major release before it is distributed to CPAN. It +is in the best interests of everyone involved if these releases are tested as +widely as possible. + +=head1 DEPRECATION POLICY + +Moose has always prioritized correctness over performance and backwards +compatibility. + +Major deprecations or API changes are documented in the Changes file as well +as in L<Moose::Manual::Delta>. The Moose developers will also make an effort +to warn users of upcoming deprecations and breakage through the Moose blog +(http://blog.moose.perl.org). + +Deprecated APIs will be preserved for at least one year I<after the major +release which deprecates that API>. Deprecated APIs will only be removed in a +major release. + +Moose will also warn during installation if the version of Moose being +installed will break an installed dependency. Unfortunately, due to the nature +of the Perl install process these warnings may be easy to miss. + +=head1 BACKWARDS COMPATIBILITY + +We try to ensure compatibility by having a extensive test suite (last count +over 18000 tests), as well as testing a number of packages (currently just +under 100 packages) that depend on Moose before any release. + +The current list of downstream dependencies that are tested is in +C<xt/author/test-my-dependents.t>. + +=head1 VERSION NUMBERS + +Moose version numbers consist of three parts, in the form X.YYZZ. The X is the +"special magic number" that only gets changed for really big changes. Think of +this as being like the "5" in Perl 5.12.1. + +The YY portion is the major version number. Moose uses even numbers for stable +releases, and odd numbers for trial releases. The ZZ is the minor version, and +it simply increases monotonically. It starts at "00" each time a new major +version is released. + +Semantically, this means that any two releases which share a major version +should be API-compatible with each other. In other words, 2.0200, 2.0201, and +2.0274 are all API-compatible. + +Prior to version 2.0, Moose version numbers were monotonically incrementing +two decimal values (0.01, 0.02, ... 1.11, 1.12, etc.). + +Moose was declared production ready at version 0.18 (via L<< +http://www.perlmonks.org/?node_id=608144 >>). + +=head1 PERL VERSION COMPATIBILITY + +As of version 2.16, Moose will officially support being run on perl 5.10.1+. Our +current policy is to support the earliest version of Perl shipped in the latest +stable release of any major operating system (this tends to mean CentOS). We +will provide at least six months notice (two major releases) when we decide to +increase the officially supported Perl version. + +"Officially supported" does not mean that these are the only versions of Perl +that Moose will work with. Our declared perl dependency will remain at 5.8.3 +as long as our test suite continues to pass on 5.8.3. What this does mean is +that the core Moose dev team will not be spending any time fixing bugs on +versions that aren't officially supported, and new contributions will not be +rejected due to being incompatible with older versions of perl except in the +most trivial of cases. We will, however, still welcome patches to make Moose +compatible with earlier versions, if other people are still interested in +maintaining compatibility. As such, the current minimum required version of +5.8.3 will remain for as long as downstream users are happy to assist with +maintenance. + +Note that although performance regressions are acceptable in order to maintain +backwards compatibility (as long as they only affect the older versions), +functionality changes and buggy behavior will not be. If it becomes impossible +to provide identical functionality between modern Perl versions and +unsupported Perl versions, we will increase our declared perl dependency +instead. + +=head1 CONTRIBUTING + +Moose has an open contribution policy. Anybody is welcome to submit a +patch. Please see L<Moose::Manual::Contributing> for more details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Types.pod b/lib/Moose/Manual/Types.pod new file mode 100644 index 0000000..9ff7532 --- /dev/null +++ b/lib/Moose/Manual/Types.pod @@ -0,0 +1,491 @@ +# PODNAME: Moose::Manual::Types +# ABSTRACT: Moose's type system + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Types - Moose's type system + +=head1 VERSION + +version 2.1405 + +=head1 TYPES IN PERL? + +Moose provides its own type system for attributes. You can also use +these types to validate method parameters with the help of a MooseX +module. + +Moose's type system is based on a combination of Perl 5's own +I<implicit> types and some Perl 6 concepts. You can create your +own subtypes with custom constraints, making it easy to express any +sort of validation. + +Types have names, and you can re-use them by name, making it easy to +share types throughout a large application. + +However, this is not a "real" type system. Moose does not magically make Perl +start associating types with variables. This is just an advanced parameter +checking system which allows you to associate a name with a constraint. + +That said, it's still pretty damn useful, and we think it's one of the +things that makes Moose both fun and powerful. Taking advantage of the +type system makes it much easier to ensure that you are getting valid +data, and it also contributes greatly to code maintainability. + +=head1 THE TYPES + +The basic Moose type hierarchy looks like this + + Any + Item + Bool + Maybe[`a] + Undef + Defined + Value + Str + Num + Int + ClassName + RoleName + Ref + ScalarRef[`a] + ArrayRef[`a] + HashRef[`a] + CodeRef + RegexpRef + GlobRef + FileHandle + Object + +In practice, the only difference between C<Any> and C<Item> is +conceptual. C<Item> is used as the top-level type in the hierarchy. + +The rest of these types correspond to existing Perl concepts. +In particular: + +=over 4 + +=item + +C<Bool> accepts C<1> for true, and undef, 0, or the empty string as false. + +=item + +C<Maybe[`a]> accepts either C<`a> or C<undef>. + +=item + +C<Num> accepts integers, floating point numbers (both in decimal notation & +exponential notation), 0, .0, 0.0 etc. It doesn't accept numbers with +whitespace, Inf, Infinity, "0 but true", NaN & other such strings. + +=item + +C<ClassName> and C<RoleName> accept strings that are either the name of a class or the name of a role. The class/role must already be loaded when the constraint is checked. + +=item + +C<FileHandle> accepts either an L<IO::Handle> object or a builtin perl filehandle (see L<Scalar::Util/openhandle>). + +=item + +C<Object> accepts any blessed reference. + +=back + +The types followed by "[`a]" can be parameterized. So instead of just +plain C<ArrayRef> we can say that we want C<ArrayRef[Int]> instead. We +can even do something like C<HashRef[ArrayRef[Str]]>. + +The C<Maybe[`a]> type deserves a special mention. Used by itself, it +doesn't really mean anything (and is equivalent to C<Item>). When it +is parameterized, it means that the value is either C<undef> or the +parameterized type. So C<Maybe[Int]> means an integer or C<undef>. + +For more details on the type hierarchy, see +L<Moose::Util::TypeConstraints>. + +=head1 WHAT IS A TYPE? + +It's important to realize that types are not classes (or +packages). Types are just objects (L<Moose::Meta::TypeConstraint> +objects, to be exact) with a name and a constraint. Moose maintains a +global type registry that lets it convert names like C<Num> into the +appropriate object. + +However, class names I<can be> type names. When you define a new class +using Moose, it defines an associated type name behind the scenes: + + package MyApp::User; + + use Moose; + +Now you can use C<'MyApp::User'> as a type name: + + has creator => ( + is => 'ro', + isa => 'MyApp::User', + ); + +However, for non-Moose classes there's no magic. You may have to +explicitly declare the class type. This is a bit muddled because Moose +assumes that any unknown type name passed as the C<isa> value for an +attribute is a class. So this works: + + has 'birth_date' => ( + is => 'ro', + isa => 'DateTime', + ); + +In general, when Moose is presented with an unknown name, it assumes +that the name is a class: + + subtype 'ModernDateTime' + => as 'DateTime' + => where { $_->year() >= 1980 } + => message { 'The date you provided is not modern enough' }; + + has 'valid_dates' => ( + is => 'ro', + isa => 'ArrayRef[DateTime]', + ); + +Moose will assume that C<DateTime> is a class name in both of these +instances. + +=head1 SUBTYPES + +Moose uses subtypes in its built-in hierarchy. For example, C<Int> is +a child of C<Num>. + +A subtype is defined in terms of a parent type and a constraint. Any +constraints defined by the parent(s) will be checked first, followed by +constraints defined by the subtype. A value must pass I<all> of these +checks to be valid for the subtype. + +Typically, a subtype takes the parent's constraint and makes it more +specific. + +A subtype can also define its own constraint failure message. This +lets you do things like have an error "The value you provided (20), +was not a valid rating, which must be a number from 1-10." This is +much friendlier than the default error, which just says that the value +failed a validation check for the type. The default error can, however, +be made more friendly by installing L<Devel::PartialDump> (version 0.14 or +higher), which Moose will use if possible to display the invalid value. + +Here's a simple (and useful) subtype example: + + subtype 'PositiveInt', + as 'Int', + where { $_ > 0 }, + message { "The number you provided, $_, was not a positive number" }; + +Note that the sugar functions for working with types are all exported +by L<Moose::Util::TypeConstraints>. + +=head1 TYPE NAMES + +Type names are global throughout the current Perl +interpreter. Internally, Moose maps names to type objects via a +L<registry|Moose::Meta::TypeConstraint::Registry>. + +If you have multiple apps or libraries all using Moose in the same +process, you could have problems with collisions. We recommend that +you prefix names with some sort of namespace indicator to prevent +these sorts of collisions. + +For example, instead of calling a type "PositiveInt", call it +"MyApp::Type::PositiveInt" or "MyApp::Types::PositiveInt". We +recommend that you centralize all of these definitions in a single +package, C<MyApp::Types>, which can be loaded by other classes in your +application. + +However, before you do this, you should look at the L<MooseX::Types> +module. This module makes it easy to create a "type library" module, which can +export your types as perl constants. + + has 'counter' => (is => 'rw', isa => PositiveInt); + +This lets you use a short name rather than needing to fully qualify the name +everywhere. It also allows you to easily create parameterized types: + + has 'counts' => (is => 'ro', isa => HashRef[PositiveInt]); + +This module will check your names at compile time, and is generally more +robust than the string type parsing for complex cases. + +=head1 COERCION + +A coercion lets you tell Moose to automatically convert one type to another. + + subtype 'ArrayRefOfInts', + as 'ArrayRef[Int]'; + + coerce 'ArrayRefOfInts', + from 'Int', + via { [ $_ ] }; + +You'll note that we created a subtype rather than coercing C<ArrayRef[Int]> +directly. It's a bad idea to add coercions to the raw built in +types. + +Coercions are global, just like type names, so a coercion applied to a built +in type is seen by all modules using Moose types. This is I<another> reason +why it is good to namespace your types. + +Moose will I<never> try to coerce a value unless you explicitly ask for +it. This is done by setting the C<coerce> attribute option to a true value: + + package Foo; + + has 'sizes' => ( + is => 'ro', + isa => 'ArrayRefOfInts', + coerce => 1, + ); + + Foo->new( sizes => 42 ); + +This code example will do the right thing, and the newly created +object will have C<[ 42 ]> as its C<sizes> attribute. + +=head2 Deep coercion + +Deep coercion is the coercion of type parameters for parameterized +types. Let's take these types as an example: + + subtype 'HexNum', + as 'Str', + where { /[a-f0-9]/i }; + + coerce 'Int', + from 'HexNum', + via { hex $_ }; + + has 'sizes' => ( + is => 'ro', + isa => 'ArrayRef[Int]', + coerce => 1, + ); + +If we try passing an array reference of hex numbers for the C<sizes> +attribute, Moose will not do any coercion. + +However, you can define a set of subtypes to enable coercion between +two parameterized types. + + subtype 'ArrayRefOfHexNums', + as 'ArrayRef[HexNum]'; + + subtype 'ArrayRefOfInts', + as 'ArrayRef[Int]'; + + coerce 'ArrayRefOfInts', + from 'ArrayRefOfHexNums', + via { [ map { hex } @{$_} ] }; + + Foo->new( sizes => [ 'a1', 'ff', '22' ] ); + +Now Moose will coerce the hex numbers to integers. + +Moose does not attempt to chain coercions, so it will not +coerce a single hex number. To do that, we need to define a separate +coercion: + + coerce 'ArrayRefOfInts', + from 'HexNum', + via { [ hex $_ ] }; + +Yes, this can all get verbose, but coercion is tricky magic, and we +think it's best to make it explicit. + +=head1 TYPE UNIONS + +Moose allows you to say that an attribute can be of two or more +disparate types. For example, we might allow an C<Object> or +C<FileHandle>: + + has 'output' => ( + is => 'rw', + isa => 'Object | FileHandle', + ); + +Moose actually parses that string and recognizes that you are creating +a type union. The C<output> attribute will accept any sort of object, +as well as an unblessed file handle. It is up to you to do the right +thing for each of them in your code. + +Whenever you use a type union, you should consider whether or not +coercion might be a better answer. + +For our example above, we might want to be more specific, and insist +that output be an object with a C<print> method: + + duck_type 'CanPrint', [qw(print)]; + +We can coerce file handles to an object that satisfies this condition +with a simple wrapper class: + + package FHWrapper; + + use Moose; + + has 'handle' => ( + is => 'rw', + isa => 'FileHandle', + ); + + sub print { + my $self = shift; + my $fh = $self->handle(); + + print {$fh} @_; + } + +Now we can define a coercion from C<FileHandle> to our wrapper class: + + coerce 'CanPrint' + => from 'FileHandle' + => via { FHWrapper->new( handle => $_ ) }; + + has 'output' => ( + is => 'rw', + isa => 'CanPrint', + coerce => 1, + ); + +This pattern of using a coercion instead of a type union will help +make your class internals simpler. + +=head1 TYPE CREATION HELPERS + +The L<Moose::Util::TypeConstraints> module exports a number of helper +functions for creating specific kinds of types. These include +C<class_type>, C<role_type>, C<maybe_type>, and C<duck_type>. See the +docs for details. + +One helper worth noting is C<enum>, which allows you to create a +subtype of C<Str> that only allows the specified values: + + enum 'RGB', [qw( red green blue )]; + +This creates a type named C<RGB>. + +=head1 ANONYMOUS TYPES + +All of the type creation functions return a type object. This type +object can be used wherever you would use a type name, as a parent +type, or as the value for an attribute's C<isa> option: + + has 'size' => ( + is => 'ro', + isa => subtype( 'Int' => where { $_ > 0 } ), + ); + +This is handy when you want to create a one-off type and don't want to +"pollute" the global namespace registry. + +=head1 VALIDATING METHOD PARAMETERS + +Moose does not provide any means of validating method +parameters. However, there are several MooseX extensions on CPAN which +let you do this. + +The simplest and least sugary is L<MooseX::Params::Validate>. This +lets you validate a set of named parameters using Moose types: + + use Moose; + use MooseX::Params::Validate; + + sub foo { + my $self = shift; + my %params = validated_hash( + \@_, + bar => { isa => 'Str', default => 'Moose' }, + ); + ... + } + +L<MooseX::Params::Validate> also supports coercions. + +There are several more powerful extensions that support method +parameter validation using Moose types, including +L<MooseX::Method::Signatures>, which gives you a full-blown C<method> +keyword. + + method morning ( Str $name ) { + $self->say("Good morning ${name}!"); + } + +=head1 LOAD ORDER ISSUES + +Because Moose types are defined at runtime, you may run into load +order problems. In particular, you may want to use a class's type +constraint before that type has been defined. + +In order to ameliorate this problem, we recommend defining I<all> of your +custom types in one module, C<MyApp::Types>, and then loading this module in +all of your other modules. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Manual/Unsweetened.pod b/lib/Moose/Manual/Unsweetened.pod new file mode 100644 index 0000000..bd36927 --- /dev/null +++ b/lib/Moose/Manual/Unsweetened.pod @@ -0,0 +1,386 @@ +# PODNAME: Moose::Manual::Unsweetened +# ABSTRACT: Moose idioms in plain old Perl 5 without the sugar + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Manual::Unsweetened - Moose idioms in plain old Perl 5 without the sugar + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +If you're trying to figure out just what the heck Moose does, and how +it saves you time, you might find it helpful to see what Moose is +I<really> doing for you. This document shows you the translation from +Moose sugar back to plain old Perl 5. + +=head1 CLASSES AND ATTRIBUTES + +First, we define two very small classes the Moose way. + + package Person; + + use DateTime; + use DateTime::Format::Natural; + use Moose; + use Moose::Util::TypeConstraints; + + has name => ( + is => 'rw', + isa => 'Str', + required => 1, + ); + + # Moose doesn't know about non-Moose-based classes. + class_type 'DateTime'; + + my $en_parser = DateTime::Format::Natural->new( + lang => 'en', + time_zone => 'UTC', + ); + + coerce 'DateTime' + => from 'Str' + => via { $en_parser->parse_datetime($_) }; + + has birth_date => ( + is => 'rw', + isa => 'DateTime', + coerce => 1, + handles => { birth_year => 'year' }, + ); + + enum 'ShirtSize' => [qw( 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 an enum +type to validate t-shirt sizes because we don't want to end up with something +like "blue" for the shirt size! + + package User; + + use Email::Valid; + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Person'; + + subtype 'Email' + => as 'Str' + => where { Email::Valid->address($_) } + => message { "$_ is not a valid email address" }; + + has email_address => ( + is => 'rw', + isa => 'Email', + required => 1, + ); + +This class subclasses Person to add a single attribute, email address. + +Now we will show what these classes would look like in plain old Perl +5. For the sake of argument, we won't use any base classes or any +helpers like C<Class::Accessor>. + + package Person; + + use strict; + use warnings; + + use Carp qw( confess ); + use DateTime; + use DateTime::Format::Natural; + + sub new { + my $class = shift; + my %p = ref $_[0] ? %{ $_[0] } : @_; + + exists $p{name} + or confess 'name is a required attribute'; + $class->_validate_name( $p{name} ); + + exists $p{birth_date} + or confess 'birth_date is a required attribute'; + + $p{birth_date} = $class->_coerce_birth_date( $p{birth_date} ); + $class->_validate_birth_date( $p{birth_date} ); + + $p{shirt_size} = 'l' + unless exists $p{shirt_size}: + + $class->_validate_shirt_size( $p{shirt_size} ); + + return bless \%p, $class; + } + + sub _validate_name { + shift; + my $name = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + + defined $name + or confess 'name must be a string'; + } + + { + my $en_parser = DateTime::Format::Natural->new( + lang => 'en', + time_zone => 'UTC', + ); + + sub _coerce_birth_date { + shift; + my $date = shift; + + return $date unless defined $date && ! ref $date; + + my $dt = $en_parser->parse_datetime($date); + + return $dt ? $dt : undef; + } + } + + sub _validate_birth_date { + shift; + my $birth_date = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + + $birth_date->isa('DateTime') + or confess 'birth_date must be a DateTime object'; + } + + sub _validate_shirt_size { + shift; + my $shirt_size = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + + defined $shirt_size + or confess 'shirt_size cannot be undef'; + + my %sizes = map { $_ => 1 } qw( s m l xl xxl ); + + $sizes{$shirt_size} + or confess "$shirt_size is not a valid shirt size (s, m, l, xl, xxl)"; + } + + sub name { + my $self = shift; + + if (@_) { + $self->_validate_name( $_[0] ); + $self->{name} = $_[0]; + } + + return $self->{name}; + } + + sub birth_date { + my $self = shift; + + if (@_) { + my $date = $self->_coerce_birth_date( $_[0] ); + $self->_validate_birth_date( $date ); + + $self->{birth_date} = $date; + } + + return $self->{birth_date}; + } + + sub birth_year { + my $self = shift; + + return $self->birth_date->year; + } + + sub shirt_size { + my $self = shift; + + if (@_) { + $self->_validate_shirt_size( $_[0] ); + $self->{shirt_size} = $_[0]; + } + + return $self->{shirt_size}; + } + +Wow, that was a mouthful! One thing to note is just how much space the +data validation code consumes. As a result, it's pretty common for +Perl 5 programmers to just not bother. Unfortunately, not validating +arguments leads to surprises down the line ("why is birth_date an +email address?"). + +Also, did you spot the (intentional) bug? + +It's in the C<_validate_birth_date()> method. We should check that +the value in C<$birth_date> is actually defined and an object before +we go and call C<isa()> on it! Leaving out those checks means our data +validation code could actually cause our program to die. Oops. + +Note that if we add a superclass to Person we'll have to change the +constructor to account for that. + +(As an aside, getting all the little details of what Moose does for +you just right in this example was really not easy, which emphasizes +the point of the example. Moose saves you a lot of work!) + +Now let's see User: + + package User; + + use strict; + use warnings; + + use Carp qw( confess ); + use Email::Valid; + use Scalar::Util qw( blessed ); + + use parent 'Person'; + + sub new { + my $class = shift; + my %p = ref $_[0] ? %{ $_[0] } : @_; + + exists $p{email_address} + or confess 'email_address is a required attribute'; + $class->_validate_email_address( $p{email_address} ); + + my $self = $class->SUPER::new(%p); + + $self->{email_address} = $p{email_address}; + + return $self; + } + + sub _validate_email_address { + shift; + my $email_address = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + + defined $email_address + or confess 'email_address must be a string'; + + Email::Valid->address($email_address) + or confess "$email_address is not a valid email address"; + } + + sub email_address { + my $self = shift; + + if (@_) { + $self->_validate_email_address( $_[0] ); + $self->{email_address} = $_[0]; + } + + return $self->{email_address}; + } + +That one was shorter, but it only has one attribute. + +Between the two classes, we have a whole lot of code that doesn't do +much. We could probably simplify this by defining some sort of +"attribute and validation" hash, like this: + + package Person; + + my %Attr = ( + name => { + required => 1, + validate => sub { defined $_ }, + }, + birth_date => { + required => 1, + validate => sub { blessed $_ && $_->isa('DateTime') }, + }, + shirt_size => { + required => 1, + validate => sub { defined $_ && $_ =~ /^(?:s|m|l|xl|xxl)$/i }, + } + ); + +Then we could define a base class that would accept such a definition +and do the right thing. Keep that sort of thing up and we're well on +our way to writing a half-assed version of Moose! + +Of course, there are CPAN modules that do some of what Moose does, +like C<Class::Accessor>, C<Class::Meta>, and so on. But none of them +put together all of Moose's features along with a layer of declarative +sugar, nor are these other modules designed for extensibility in the +same way as Moose. With Moose, it's easy to write a MooseX module to +replace or extend a piece of built-in functionality. + +Moose is a complete OO package in and of itself, and is part of a rich +ecosystem of extensions. It also has an enthusiastic community of +users and is being actively maintained and developed. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm new file mode 100644 index 0000000..0c91693 --- /dev/null +++ b/lib/Moose/Meta/Attribute.pm @@ -0,0 +1,1734 @@ +use strict; +use warnings; +package Moose::Meta::Attribute; +our $VERSION = '2.1405'; + +use B (); +use Scalar::Util 'blessed'; +use List::Util 1.33 'any'; +use Try::Tiny; +use overload (); + +use Moose::Deprecated; +use Moose::Meta::Method::Accessor; +use Moose::Meta::Method::Delegation; +use Moose::Util 'throw_exception'; +use Moose::Util::TypeConstraints (); +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; + +use Carp 'confess'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +__PACKAGE__->meta->add_attribute('traits' => ( + reader => 'applied_traits', + predicate => 'has_applied_traits', + Class::MOP::_definition_context(), +)); + +# we need to have a ->does method in here to +# more easily support traits, and the introspection +# of those traits. We extend the does check to look +# for metatrait aliases. +sub does { + my ($self, $role_name) = @_; + my $name = try { + Moose::Util::resolve_metatrait_alias(Attribute => $role_name) + }; + return 0 if !defined($name); # failed to load class + return $self->Moose::Object::does($name); +} + +sub _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')'; +} + +sub new { + my ($class, $name, %options) = @_; + $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS + + delete $options{__hack_no_process_options}; + + my %attrs = + ( map { $_ => 1 } + grep { defined } + map { $_->init_arg() } + $class->meta()->get_all_attributes() + ); + + my @bad = sort grep { ! $attrs{$_} } keys %options; + + if (@bad) + { + my $s = @bad > 1 ? 's' : ''; + my $list = join "', '", @bad; + + my $package = $options{definition_context}{package}; + my $context = $options{definition_context}{context} + || 'attribute constructor'; + my $type = $options{definition_context}{type} || 'class'; + + my $location = ''; + if (defined($package)) { + $location = " in "; + $location .= "$type " if $type; + $location .= $package; + } + + Carp::cluck "Found unknown argument$s '$list' in the $context for '$name'$location"; + } + + return $class->SUPER::new($name, %options); +} + +sub interpolate_class_and_new { + my $class = shift; + my $name = shift; + + throw_exception( MustPassEvenNumberOfAttributeOptions => attribute_name => $name, + options => \@_ + ) + if @_ % 2 == 1; + + my %args = @_; + + my ( $new_class, @traits ) = $class->interpolate_class(\%args); + $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); +} + +sub interpolate_class { + my ($class, $options) = @_; + + $class = ref($class) || $class; + + if ( my $metaclass_name = delete $options->{metaclass} ) { + my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name ); + + if ( $class ne $new_class ) { + if ( $new_class->can("interpolate_class") ) { + return $new_class->interpolate_class($options); + } else { + $class = $new_class; + } + } + } + + my @traits; + + if (my $traits = $options->{traits}) { + my $i = 0; + my $has_foreign_options = 0; + + while ($i < @$traits) { + my $trait = $traits->[$i++]; + next if ref($trait); # options to a trait we discarded + + $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait) + || $trait; + + next if $class->does($trait); + + push @traits, $trait; + + # are there options? + if ($traits->[$i] && ref($traits->[$i])) { + $has_foreign_options = 1 + if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] }; + + push @traits, $traits->[$i++]; + } + } + + if (@traits) { + my %options = ( + superclasses => [ $class ], + roles => [ @traits ], + ); + + if ($has_foreign_options) { + $options{weaken} = 0; + } + else { + $options{cache} = 1; + } + + my $anon_class = Moose::Meta::Class->create_anon_class(%options); + $class = $anon_class->name; + } + } + + return ( wantarray ? ( $class, @traits ) : $class ); +} + +# ... + +# method-generating options shouldn't be overridden +sub illegal_options_for_inheritance { + qw(reader writer accessor clearer predicate) +} + +# 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) = @_; + + # 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 @illegal_options = $self->can('illegal_options_for_inheritance') + ? $self->illegal_options_for_inheritance + : (); + + my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options; + (scalar @found_illegal_options == 0) + || throw_exception( IllegalInheritedOptions => illegal_options => \@found_illegal_options, + params => \%options + ); + + $self->_process_isa_option( $self->name, \%options ); + $self->_process_does_option( $self->name, \%options ); + + # NOTE: + # this doesn't apply to Class::MOP::Attributes, + # so we can ignore it for them. + # - SL + if ($self->can('interpolate_class')) { + ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); + + my %seen; + my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; + $options{traits} = \@all_traits if @all_traits; + } + + # This method can be called on a CMOP::Attribute object, so we need to + # make sure we can call this method. + $self->_process_lazy_build_option( $self->name, \%options ) + if $self->can('_process_lazy_build_option'); + + $self->clone(%options); +} + +sub clone { + my ( $self, %params ) = @_; + + my $class = delete $params{metaclass} || ref $self; + + my ( @init, @non_init ); + + foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) { + push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; + } + + my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); + + my $name = delete $new_params{name}; + + my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); + + foreach my $attr ( @non_init ) { + $attr->set_value($clone, $attr->get_value($self)); + } + + return $clone; +} + +sub _process_options { + my ( $class, $name, $options ) = @_; + + $class->_process_is_option( $name, $options ); + $class->_process_isa_option( $name, $options ); + $class->_process_does_option( $name, $options ); + $class->_process_coerce_option( $name, $options ); + $class->_process_trigger_option( $name, $options ); + $class->_process_auto_deref_option( $name, $options ); + $class->_process_lazy_build_option( $name, $options ); + $class->_process_lazy_option( $name, $options ); + $class->_process_required_option( $name, $options ); +} + +sub _process_is_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{is}; + + ### ------------------------- + ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before + ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + ## is => rw, accessor => _foo # turns into (accessor => _foo) + ## is => ro, accessor => _foo # error, accesor is rw + ### ------------------------- + + if ( $options->{is} eq 'ro' ) { + throw_exception("AccessorMustReadWrite" => attribute_name => $name, + params => $options, + ) + if exists $options->{accessor}; + $options->{reader} ||= $name; + } + elsif ( $options->{is} eq 'rw' ) { + if ( $options->{writer} ) { + $options->{reader} ||= $name; + } + else { + $options->{accessor} ||= $name; + } + } + elsif ( $options->{is} eq 'bare' ) { + return; + # do nothing, but don't complain (later) about missing methods + } + else { + throw_exception( InvalidValueForIs => attribute_name => $name, + params => $options, + ); + } +} + +sub _process_isa_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{isa}; + + if ( exists $options->{does} ) { + if ( try { $options->{isa}->can('does') } ) { + ( $options->{isa}->does( $options->{does} ) ) + || throw_exception( IsaDoesNotDoTheRole => attribute_name => $name, + params => $options, + ); + } + else { + throw_exception( IsaLacksDoesMethod => attribute_name => $name, + params => $options, + ); + } + } + + # allow for anon-subtypes here ... + # + # Checking for Specio explicitly is completely revolting. At some point + # this needs to be refactored so that Moose core defines a standard type + # API that all types must implement. Unfortunately, the current core API + # is _not_ the right API, so we probably need to A) come up with the new + # API (Specio is a good start); B) refactor the core types to implement + # that API; C) do duck type checking on type objects. + if ( blessed( $options->{isa} ) + && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{isa}; + } + elsif ( + blessed( $options->{isa} ) + && $options->{isa}->can('does') + && $options->{isa}->does('Specio::Constraint::Role::Interface') + ) { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} + = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint( + $options->{isa}, + { package_defined_in => $options->{definition_context}->{package} } + ); + } +} + +sub _process_does_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{does} && ! exists $options->{isa}; + + # allow for anon-subtypes here ... + if ( blessed( $options->{does} ) + && $options->{does}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{does}; + } + else { + $options->{type_constraint} + = Moose::Util::TypeConstraints::find_or_create_does_type_constraint( + $options->{does}, + { package_defined_in => $options->{definition_context}->{package} } + ); + } +} + +sub _process_coerce_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{coerce}; + + ( exists $options->{type_constraint} ) + || throw_exception( CoercionNeedsTypeConstraint => attribute_name => $name, + params => $options, + ); + + throw_exception( CannotCoerceAWeakRef => attribute_name => $name, + params => $options, + ) + if $options->{weak_ref}; + + unless ( $options->{type_constraint}->has_coercion ) { + my $type = $options->{type_constraint}->name; + + throw_exception( CannotCoerceAttributeWhichHasNoCoercion => attribute_name => $name, + type_name => $type, + params => $options + ); + } +} + +sub _process_trigger_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{trigger}; + + ( 'CODE' eq ref $options->{trigger} ) + || throw_exception( TriggerMustBeACodeRef => attribute_name => $name, + params => $options, + ); +} + +sub _process_auto_deref_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{auto_deref}; + + ( exists $options->{type_constraint} ) + || throw_exception( CannotAutoDerefWithoutIsa => attribute_name => $name, + params => $options, + ); + + ( $options->{type_constraint}->is_a_type_of('ArrayRef') + || $options->{type_constraint}->is_a_type_of('HashRef') ) + || throw_exception( AutoDeRefNeedsArrayRefOrHashRef => attribute_name => $name, + params => $options, + ); +} + +sub _process_lazy_build_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy_build}; + + throw_exception( CannotUseLazyBuildAndDefaultSimultaneously => attribute_name => $name, + params => $options, + ) + if exists $options->{default}; + + $options->{lazy} = 1; + $options->{builder} ||= "_build_${name}"; + + if ( $name =~ /^_/ ) { + $options->{clearer} ||= "_clear${name}"; + $options->{predicate} ||= "_has${name}"; + } + else { + $options->{clearer} ||= "clear_${name}"; + $options->{predicate} ||= "has_${name}"; + } +} + +sub _process_lazy_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy}; + + ( exists $options->{default} || defined $options->{builder} ) + || throw_exception( LazyAttributeNeedsADefault => params => $options, + attribute_name => $name, + ); +} + +sub _process_required_option { + my ( $class, $name, $options ) = @_; + + if ( + $options->{required} + && !( + ( !exists $options->{init_arg} || defined $options->{init_arg} ) + || exists $options->{default} + || defined $options->{builder} + ) + ) { + throw_exception( RequiredAttributeNeedsADefault => params => $options, + attribute_name => $name, + ); + } +} + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + + my $val; + my $value_is_set; + if ( defined($init_arg) and exists $params->{$init_arg}) { + $val = $params->{$init_arg}; + $value_is_set = 1; + } + else { + # skip it if it's lazy + return if $self->is_lazy; + # and die if it's required and doesn't have a default value + my $class_name = blessed( $instance ); + throw_exception(AttributeIsRequired => attribute_name => $self->name, + class_name => $class_name, + params => $params, + ) + if $self->is_required && !$self->has_default && !$self->has_builder; + + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if ($self->has_default) { + $val = $self->default($instance); + $value_is_set = 1; + } + elsif ($self->has_builder) { + $val = $self->_call_builder($instance); + $value_is_set = 1; + } + } + + return unless $value_is_set; + + $val = $self->_coerce_and_verify( $val, $instance ); + + $self->set_initial_value($instance, $val); + + if ( ref $val && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } +} + +sub _call_builder { + my ( $self, $instance ) = @_; + + my $builder = $self->builder(); + + return $instance->$builder() + if $instance->can( $self->builder ); + + throw_exception( BuilderDoesNotExist => instance => $instance, + attribute => $self, + ); +} + +## Slot management + +sub _make_initializer_writer_callback { + my $self = shift; + my ($meta_instance, $instance, $slot_name) = @_; + my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_); + return sub { + $old_callback->($self->_coerce_and_verify($_[0], $instance)); + }; +} + +sub set_value { + my ($self, $instance, @args) = @_; + my $value = $args[0]; + + my $attr_name = quotemeta($self->name); + + my $class_name = blessed( $instance ); + if ($self->is_required and not @args) { + throw_exception( AttributeIsRequired => attribute_name => $self->name, + class_name => $class_name, + ); + } + + $value = $self->_coerce_and_verify( $value, $instance ); + + my @old; + if ( $self->has_trigger && $self->has_value($instance) ) { + @old = $self->get_value($instance, 'for trigger'); + } + + $self->SUPER::set_value($instance, $value); + + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } + + if ($self->has_trigger) { + $self->trigger->($instance, $value, @old); + } +} + +sub _inline_set_value { + my $self = shift; + my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_; + + my $old = '@old'; + my $copy = '$val'; + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $message ||= '$type_message'; + + my @code; + if ($self->_writer_value_needs_copy) { + push @code, $self->_inline_copy_value($value, $copy); + $value = $copy; + } + + # constructors already handle required checks + push @code, $self->_inline_check_required + unless $for_constructor; + + push @code, $self->_inline_tc_code($value, $tc, $coercion, $message); + + # constructors do triggers all at once at the end + push @code, $self->_inline_get_old_value_for_trigger($instance, $old) + unless $for_constructor; + + push @code, ( + $self->SUPER::_inline_set_value($instance, $value), + $self->_inline_weaken_value($instance, $value), + ); + + # constructors do triggers all at once at the end + push @code, $self->_inline_trigger($instance, $value, $old) + unless $for_constructor; + + return @code; +} + +sub _writer_value_needs_copy { + my $self = shift; + return $self->should_coerce; +} + +sub _inline_copy_value { + my $self = shift; + my ($value, $copy) = @_; + + return 'my ' . $copy . ' = ' . $value . ';' +} + +sub _inline_check_required { + my $self = shift; + + return unless $self->is_required; + + my $attr_name = quotemeta($self->name); + + return ( + 'if (@_ < 2) {', + $self->_inline_throw_exception( AttributeIsRequired => + 'attribute_name => "'.$attr_name.'",'. + 'class_name => $class_name' + ) . ';', + '}', + ); +} + +sub _inline_tc_code { + my $self = shift; + my ($value, $tc, $coercion, $message, $is_lazy) = @_; + return ( + $self->_inline_check_coercion( + $value, $tc, $coercion, $is_lazy, + ), + $self->_inline_check_constraint( + $value, $tc, $message, $is_lazy, + ), + ); +} + +sub _inline_check_coercion { + my $self = shift; + my ($value, $tc, $coercion) = @_; + + return unless $self->should_coerce && $self->type_constraint->has_coercion; + + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } +} + +sub _inline_check_constraint { + my $self = shift; + my ($value, $tc, $message) = @_; + + return unless $self->has_type_constraint; + + my $attr_name = quotemeta($self->name); + + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + 'my $msg = do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ');' + . '};'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + 'type_constraint_message => $msg , '. + 'class_name => $class_name, '. + 'attribute_name => "'.$attr_name.'",'. + 'value => '.$value + ).';', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + 'my $msg = do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ');' + . '};'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + 'type_constraint_message => $msg , '. + 'class_name => $class_name, '. + 'attribute_name => "'.$attr_name.'",'. + 'value => '.$value + ).';', + '}', + ); + } +} + +sub _inline_get_old_value_for_trigger { + my $self = shift; + my ($instance, $old) = @_; + + return unless $self->has_trigger; + + return ( + 'my ' . $old . ' = ' . $self->_inline_instance_has($instance), + '? ' . $self->_inline_instance_get($instance), + ': ();', + ); +} + +sub _inline_weaken_value { + my $self = shift; + my ($instance, $value) = @_; + + return unless $self->is_weak_ref; + + my $mi = $self->associated_class->get_meta_instance; + return ( + $mi->inline_weaken_slot_value($instance, $self->name), + 'if ref ' . $value . ';', + ); +} + +sub _inline_trigger { + my $self = shift; + my ($instance, $value, $old) = @_; + + return unless $self->has_trigger; + + return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');'; +} + +sub _eval_environment { + my $self = shift; + + my $env = { }; + + $env->{'$trigger'} = \($self->trigger) + if $self->has_trigger; + $env->{'$attr_default'} = \($self->default) + if $self->has_default; + + if ($self->has_type_constraint) { + my $tc_obj = $self->type_constraint; + + $env->{'$type_constraint'} = \( + $tc_obj->_compiled_type_constraint + ) unless $tc_obj->can_be_inlined; + # these two could probably get inlined versions too + $env->{'$type_coercion'} = \( + $tc_obj->coercion->_compiled_type_coercion + ) if $tc_obj->has_coercion; + $env->{'$type_message'} = \( + $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message + ); + + $env = { %$env, %{ $tc_obj->inline_environment } }; + } + + $env->{'$class_name'} = \($self->associated_class->name); + + # XXX ugh, fix these + $env->{'$attr'} = \$self + if $self->has_initializer && $self->is_lazy; + # pretty sure this is only going to be closed over if you use a custom + # error class at this point, but we should still get rid of this + # at some point + $env->{'$meta'} = \($self->associated_class); + + return $env; +} + +sub _weaken_value { + my ( $self, $instance ) = @_; + + my $meta_instance = Class::MOP::Class->initialize( blessed($instance) ) + ->get_meta_instance; + + $meta_instance->weaken_slot_value( $instance, $self->name ); +} + +sub get_value { + my ($self, $instance, $for_trigger) = @_; + + if ($self->is_lazy) { + unless ($self->has_value($instance)) { + my $value; + if ($self->has_default) { + $value = $self->default($instance); + } elsif ( $self->has_builder ) { + $value = $self->_call_builder($instance); + } + + $value = $self->_coerce_and_verify( $value, $instance ); + + $self->set_initial_value($instance, $value); + + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } + } + } + + if ( $self->should_auto_deref && ! $for_trigger ) { + + my $type_constraint = $self->type_constraint; + + if ($type_constraint->is_a_type_of('ArrayRef')) { + my $rv = $self->SUPER::get_value($instance); + return unless defined $rv; + return wantarray ? @{ $rv } : $rv; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + my $rv = $self->SUPER::get_value($instance); + return unless defined $rv; + return wantarray ? %{ $rv } : $rv; + } + else { + throw_exception( CannotAutoDereferenceTypeConstraint => type_name => $type_constraint->name, + instance => $instance, + attribute => $self + ); + } + + } + else { + + return $self->SUPER::get_value($instance); + } +} + +sub _inline_get_value { + my $self = shift; + my ($instance, $tc, $coercion, $message) = @_; + + my $slot_access = $self->_inline_instance_get($instance); + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $message ||= '$type_message'; + + return ( + $self->_inline_check_lazy($instance, $tc, $coercion, $message), + $self->_inline_return_auto_deref($slot_access), + ); +} + +sub _inline_check_lazy { + my $self = shift; + my ($instance, $tc, $coercion, $message) = @_; + + return unless $self->is_lazy; + + my $slot_exists = $self->_inline_instance_has($instance); + + return ( + 'if (!' . $slot_exists . ') {', + $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'), + '}', + ); +} + +sub _inline_init_from_default { + my $self = shift; + my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_; + + if (!($self->has_default || $self->has_builder)) { + throw_exception( LazyAttributeNeedsADefault => attribute => $self ); + } + + return ( + $self->_inline_generate_default($instance, $default), + # intentionally not using _inline_tc_code, since that can be overridden + # to do things like possibly only do member tc checks, which isn't + # appropriate for checking the result of a default + $self->has_type_constraint + ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy), + $self->_inline_check_constraint($default, $tc, $message, $for_lazy)) + : (), + $self->_inline_init_slot($instance, $default), + $self->_inline_weaken_value($instance, $default), + ); +} + +sub _inline_generate_default { + my $self = shift; + my ($instance, $default) = @_; + + if ($self->has_default) { + my $source = 'my ' . $default . ' = $attr_default'; + $source .= '->(' . $instance . ')' + if $self->is_default_a_coderef; + return $source . ';'; + } + elsif ($self->has_builder) { + my $builder = B::perlstring($self->builder); + my $builder_str = quotemeta($self->builder); + my $attr_name_str = quotemeta($self->name); + return ( + 'my ' . $default . ';', + 'if (my $builder = ' . $instance . '->can(' . $builder . ')) {', + $default . ' = ' . $instance . '->$builder;', + '}', + 'else {', + 'my $class = ref(' . $instance . ') || ' . $instance . ';', + $self->_inline_throw_exception( + BuilderMethodNotSupportedForInlineAttribute => + 'class_name => $class,'. + 'attribute_name => "'.$attr_name_str.'",'. + 'instance => '.$instance.','. + 'builder => "'.$builder_str.'"' + ) . ';', + '}', + ); + } + else { + confess( + "Can't generate a default for " . $self->name + . " since no default or builder was specified" + ); + } +} + +sub _inline_init_slot { + my $self = shift; + my ($inv, $value) = @_; + + if ($self->has_initializer) { + return '$attr->set_initial_value(' . $inv . ', ' . $value . ');'; + } + else { + return $self->_inline_instance_set($inv, $value) . ';'; + } +} + +sub _inline_return_auto_deref { + my $self = shift; + + return 'return ' . $self->_auto_deref(@_) . ';'; +} + +sub _auto_deref { + my $self = shift; + my ($ref_value) = @_; + + return $ref_value unless $self->should_auto_deref; + + my $type_constraint = $self->type_constraint; + + my $sigil; + if ($type_constraint->is_a_type_of('ArrayRef')) { + $sigil = '@'; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + $sigil = '%'; + } + else { + confess( + 'Can not auto de-reference the type constraint \'' + . $type_constraint->name + . '\'' + ); + } + + return 'wantarray ' + . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' + . ': (' . $ref_value . ')'; +} + +## installing accessors + +sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } + +sub install_accessors { + my $self = shift; + $self->SUPER::install_accessors(@_); + $self->install_delegation if $self->has_handles; + return; +} + +sub _check_associated_methods { + my $self = shift; + unless ( + @{ $self->associated_methods } + || ($self->_is_metadata || '') eq 'bare' + ) { + Carp::cluck( + 'Attribute (' . $self->name . ') of class ' + . $self->associated_class->name + . ' has no associated methods' + . ' (did you mean to provide an "is" argument?)' + . "\n" + ) + } +} + +sub _process_accessors { + my $self = shift; + my ($type, $accessor, $generate_as_inline_methods) = @_; + + $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH'; + my $method = $self->associated_class->get_method($accessor); + + if ( $method + && $method->isa('Class::MOP::Method::Accessor') + && $method->associated_attribute->name ne $self->name ) { + + my $other_attr_name = $method->associated_attribute->name; + my $name = $self->name; + + Carp::cluck( + "You are overwriting an accessor ($accessor) for the $other_attr_name attribute" + . " with a new accessor method for the $name attribute" ); + } + + if ( + $method + && !$method->is_stub + && !$method->isa('Class::MOP::Method::Accessor') + && ( !$self->definition_context + || $method->package_name eq $self->definition_context->{package} ) + ) { + + Carp::cluck( + "You are overwriting a locally defined method ($accessor) with " + . "an accessor" ); + } + + if ( !$self->associated_class->has_method($accessor) + && $self->associated_class->has_package_symbol( '&' . $accessor ) ) { + + Carp::cluck( + "You are overwriting a locally defined function ($accessor) with " + . "an accessor" ); + } + + $self->SUPER::_process_accessors(@_); +} + +sub remove_accessors { + my $self = shift; + $self->SUPER::remove_accessors(@_); + $self->remove_delegation if $self->has_handles; + return; +} + +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; + + # install the delegation ... + my $associated_class = $self->associated_class; + my $class_name = $associated_class->name; + + foreach my $handle ( sort keys %handles ) { + my $method_to_call = $handles{$handle}; + my $name = "${class_name}::${handle}"; + + if ( my $method = $associated_class->get_method($handle) ) { + throw_exception( + CannotDelegateLocalMethodIsPresent => attribute => $self, + method => $method, + ) unless $method->is_stub; + } + + # 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); + + my $method = $self->_make_delegation_method($handle, $method_to_call); + + $self->associated_class->add_method($method->name, $method); + $self->associate_method($method); + } +} + +sub remove_delegation { + my $self = shift; + my %handles = $self->_canonicalize_handles; + my $associated_class = $self->associated_class; + foreach my $handle (keys %handles) { + next unless any { $handle eq $_ } + map { $_->name } + @{ $self->associated_methods }; + $self->associated_class->remove_method($handle); + } +} + +# private methods to help delegation ... + +sub _canonicalize_handles { + my $self = shift; + my $handles = $self->handles; + if (my $handle_type = ref($handles)) { + if ($handle_type eq 'HASH') { + return %{$handles}; + } + elsif ($handle_type eq 'ARRAY') { + return map { $_ => $_ } @{$handles}; + } + elsif ($handle_type eq 'Regexp') { + ($self->has_type_constraint) + || throw_exception( CannotDelegateWithoutIsa => attribute => $self ); + return map { ($_ => $_) } + grep { /$handles/ } $self->_get_delegate_method_list; + } + elsif ($handle_type eq 'CODE') { + return $handles->($self, $self->_find_delegate_metaclass); + } + elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) { + return map { $_ => $_ } @{ $handles->methods }; + } + elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) { + $handles = $handles->role; + } + else { + throw_exception( UnableToCanonicalizeHandles => attribute => $self, + handles => $handles + ); + } + } + + Moose::Util::_load_user_class($handles); + my $role_meta = Class::MOP::class_of($handles); + + (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) + || throw_exception( UnableToCanonicalizeNonRolePackage => attribute => $self, + handles => $handles + ); + + return map { $_ => $_ } + map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } ( + $role_meta->_get_local_methods, + $role_meta->get_required_method_list, + ); +} + +sub _get_delegate_method_list { + my $self = shift; + my $meta = $self->_find_delegate_metaclass; + if ($meta->isa('Class::MOP::Class')) { + return map { $_->name } # NOTE: !never! delegate &meta + grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') } + $meta->get_all_methods; + } + elsif ($meta->isa('Moose::Meta::Role')) { + return $meta->get_method_list; + } + else { + throw_exception( UnableToRecognizeDelegateMetaclass => attribute => $self, + delegate_metaclass => $meta + ); + } +} + +sub _find_delegate_metaclass { + my $self = shift; + my $class = $self->_isa_metadata; + my $role = $self->_does_metadata; + + if ( $class ) { + # make sure isa is actually a class + unless ( $self->type_constraint->isa("Moose::Meta::TypeConstraint::Class") ) { + throw_exception( DelegationToATypeWhichIsNotAClass => attribute => $self ); + } + + # make sure the class is loaded + unless ( Moose::Util::_is_package_loaded($class) ) { + throw_exception( DelegationToAClassWhichIsNotLoaded => attribute => $self, + class_name => $class + ); + } + # we might be dealing with a non-Moose class, + # and need to make our own metaclass. if there's + # already a metaclass, it will be returned + return Class::MOP::Class->initialize($class); + } + elsif ( $role ) { + unless ( Moose::Util::_is_package_loaded($role) ) { + throw_exception( DelegationToARoleWhichIsNotLoaded => attribute => $self, + role_name => $role + ); + } + + return Class::MOP::class_of($role); + } + else { + throw_exception( CannotFindDelegateMetaclass => attribute => $self ); + } +} + +sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } + +sub _make_delegation_method { + my ( $self, $handle_name, $method_to_call ) = @_; + + my @curried_arguments; + + ($method_to_call, @curried_arguments) = @$method_to_call + if 'ARRAY' eq ref($method_to_call); + + return $self->delegation_metaclass->new( + name => $handle_name, + package_name => $self->associated_class->name, + attribute => $self, + delegate_to_method => $method_to_call, + curried_arguments => \@curried_arguments, + ); +} + +sub _coerce_and_verify { + my $self = shift; + my $val = shift; + my $instance = shift; + + return $val unless $self->has_type_constraint; + + $val = $self->type_constraint->coerce($val) + if $self->should_coerce && $self->type_constraint->has_coercion; + + $self->verify_against_type_constraint($val, instance => $instance); + + return $val; +} + +sub verify_against_type_constraint { + my $self = shift; + my $val = shift; + + return 1 if !$self->has_type_constraint; + + my $type_constraint = $self->type_constraint; + + $type_constraint->check($val) + || throw_exception( ValidationFailedForTypeConstraint => type => $type_constraint, + value => $val, + attribute => $self, + ); +} + +package Moose::Meta::Attribute::Custom::Moose; +our $VERSION = '2.1403'; + +sub register_implementation { 'Moose::Meta::Attribute' } +1; + +# ABSTRACT: The Moose attribute metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute - The Moose attribute metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Attribute> that provides +additional Moose-specific functionality. + +To really understand this class, you will need to start with the +L<Class::MOP::Attribute> documentation. This class can be understood +as a set of additional features on top of the basic feature provided +by that parent class. + +=head1 INHERITANCE + +C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>. + +=head1 METHODS + +Many of the documented below override methods in +L<Class::MOP::Attribute> and add Moose specific features. + +=head2 Creation + +=over 4 + +=item B<< Moose::Meta::Attribute->new($name, %options) >> + +This method overrides the L<Class::MOP::Attribute> constructor. + +Many of the options below are described in more detail in the +L<Moose::Manual::Attributes> document. + +It adds the following options to the constructor: + +=over 8 + +=item * is => 'ro', 'rw', 'bare' + +This provides a shorthand for specifying the C<reader>, C<writer>, or +C<accessor> names. If the attribute is read-only ('ro') then it will +have a C<reader> method with the same attribute as the name. + +If it is read-write ('rw') then it will have an C<accessor> method +with the same name. If you provide an explicit C<writer> for a +read-write attribute, then you will have a C<reader> with the same +name as the attribute, and a C<writer> with the name you provided. + +Use 'bare' when you are deliberately not installing any methods +(accessor, reader, etc.) associated with this attribute; otherwise, +Moose will issue a warning when this attribute is added to a +metaclass. + +=item * isa => $type + +This option accepts a type. The type can be a string, which should be +a type name. If the type name is unknown, it is assumed to be a class +name. + +This option can also accept a L<Moose::Meta::TypeConstraint> object. + +If you I<also> provide a C<does> option, then your C<isa> option must +be a class name, and that class must do the role specified with +C<does>. + +=item * does => $role + +This is short-hand for saying that the attribute's type must be an +object which does the named role. + +=item * coerce => $bool + +This option is only valid for objects with a type constraint +(C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever +this attribute is set. + +You cannot make both this and the C<weak_ref> option true. + +=item * trigger => $sub + +This option accepts a subroutine reference, which will be called after +the attribute is set. + +=item * required => $bool + +An attribute which is required must be provided to the constructor. An +attribute which is required can also have a C<default> or C<builder>, +which will satisfy its required-ness. + +A required attribute must have a C<default>, C<builder> or a +non-C<undef> C<init_arg> + +=item * lazy => $bool + +A lazy attribute must have a C<default> or C<builder>. When an +attribute is lazy, the default value will not be calculated until the +attribute is read. + +=item * weak_ref => $bool + +If this is true, the attribute's value will be stored as a weak +reference. + +=item * documentation + +An arbitrary string that can be retrieved later by calling C<< +$attr->documentation >>. + +=item * auto_deref => $bool + +B<Note that in cases where you want this feature you are often better served +by using a L<Moose::Meta::Attribute::Native> trait instead>. + +If this is true, then the reader will dereference the value when it is +called. The attribute must have a type constraint which defines the +attribute as an array or hash reference. + +=item * lazy_build => $bool + +B<Note that use of this feature is strongly discouraged.> Some documentation +used to encourage use of this feature as a best practice, but we have changed +our minds. + +Setting this to true makes the attribute lazy and provides a number of +default methods. + + has 'size' => ( + is => 'ro', + lazy_build => 1, + ); + +is equivalent to this: + + has 'size' => ( + is => 'ro', + lazy => 1, + builder => '_build_size', + clearer => 'clear_size', + predicate => 'has_size', + ); + +If your attribute name starts with an underscore (C<_>), then the clearer +and predicate will as well: + + has '_size' => ( + is => 'ro', + lazy_build => 1, + ); + +becomes: + + has '_size' => ( + is => 'ro', + lazy => 1, + builder => '_build__size', + clearer => '_clear_size', + predicate => '_has_size', + ); + +Note the doubled underscore in the builder name. Internally, Moose +simply prepends the attribute name with "_build_" to come up with the +builder name. + +=back + +=item B<< $attr->clone(%options) >> + +This creates a new attribute based on attribute being cloned. You must +supply a C<name> option to provide a new name for the attribute. + +The C<%options> can only specify options handled by +L<Class::MOP::Attribute>. + +=back + +=head2 Value management + +=over 4 + +=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> + +This method is used internally to initialize the attribute's slot in +the object C<$instance>. + +This overrides the L<Class::MOP::Attribute> method to handle lazy +attributes, weak references, and type constraints. + +=item B<get_value> + +=item B<set_value> + + eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') }; + if($@) { + print "Oops: $@\n"; + } + +I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'> + +Before setting the value, a check is made on the type constraint of +the attribute, if it has one, to see if the value passes it. If the +value fails to pass, the set operation dies. + +Any coercion to convert values is done before checking the type constraint. + +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::Basics::Company_Subtypes> +for an example. + +=back + +=head2 Attribute Accessor generation + +=over 4 + +=item B<< $attr->install_accessors >> + +This method overrides the parent to also install delegation methods. + +If, after installing all methods, the attribute object has no associated +methods, it throws an error unless C<< is => 'bare' >> was passed to the +attribute constructor. (Trying to add an attribute that has no associated +methods is almost always an error.) + +=item B<< $attr->remove_accessors >> + +This method overrides the parent to also remove delegation methods. + +=item B<< $attr->inline_set($instance_var, $value_var) >> + +This method return a code snippet suitable for inlining the relevant +operation. It expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + +=item B<< $attr->install_delegation >> + +This method adds its delegation methods to the attribute's associated +class, if it has any to add. + +=item B<< $attr->remove_delegation >> + +This method remove its delegation methods from the attribute's +associated class. + +=item B<< $attr->accessor_metaclass >> + +Returns the accessor metaclass name, which defaults to +L<Moose::Meta::Method::Accessor>. + +=item B<< $attr->delegation_metaclass >> + +Returns the delegation metaclass name, which defaults to +L<Moose::Meta::Method::Delegation>. + +=back + +=head2 Additional Moose features + +These methods are not found in the superclass. They support features +provided by Moose. + +=over 4 + +=item B<< $attr->does($role) >> + +This indicates whether the I<attribute itself> does the given +role. The role can be given as a full class name, or as a resolvable +trait name. + +Note that this checks the attribute itself, not its type constraint, +so it is checking the attribute's metaclass and any traits applied to +the attribute. + +=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >> + +This is an alternate constructor that handles the C<metaclass> and +C<traits> options. + +Effectively, this method is a factory that finds or creates the +appropriate class for the given C<metaclass> and/or C<traits>. + +Once it has the appropriate class, it will call C<< $class->new($name, +%options) >> on that class. + +=item B<< $attr->clone_and_inherit_options(%options) >> + +This method supports the C<has '+foo'> feature. It does various bits +of processing on the supplied C<%options> before ultimately calling +the C<clone> method. + +One of its main tasks is to make sure that the C<%options> provided +does not include the options returned by the +C<illegal_options_for_inheritance> method. + +=item B<< $attr->illegal_options_for_inheritance >> + +This returns a blacklist of options that can not be overridden in a +subclass's attribute definition. + +This exists to allow a custom metaclass to change or add to the list +of options which can not be changed. + +=item B<< $attr->type_constraint >> + +Returns the L<Moose::Meta::TypeConstraint> object for this attribute, +if it has one. + +=item B<< $attr->has_type_constraint >> + +Returns true if this attribute has a type constraint. + +=item B<< $attr->verify_against_type_constraint($value) >> + +Given a value, this method returns true if the value is valid for the +attribute's type constraint. If the value is not valid, it throws an +error. + +=item B<< $attr->handles >> + +This returns the value of the C<handles> option passed to the +constructor. + +=item B<< $attr->has_handles >> + +Returns true if this attribute performs delegation. + +=item B<< $attr->is_weak_ref >> + +Returns true if this attribute stores its value as a weak reference. + +=item B<< $attr->is_required >> + +Returns true if this attribute is required to have a value. + +=item B<< $attr->is_lazy >> + +Returns true if this attribute is lazy. + +=item B<< $attr->is_lazy_build >> + +Returns true if the C<lazy_build> option was true when passed to the +constructor. + +=item B<< $attr->should_coerce >> + +Returns true if the C<coerce> option passed to the constructor was +true. + +=item B<< $attr->should_auto_deref >> + +Returns true if the C<auto_deref> option passed to the constructor was +true. + +=item B<< $attr->trigger >> + +This is the subroutine reference that was in the C<trigger> option +passed to the constructor, if any. + +=item B<< $attr->has_trigger >> + +Returns true if this attribute has a trigger set. + +=item B<< $attr->documentation >> + +Returns the value that was in the C<documentation> option passed to +the constructor, if any. + +=item B<< $attr->has_documentation >> + +Returns true if this attribute has any documentation. + +=item B<< $attr->applied_traits >> + +This returns an array reference of all the traits which were applied +to this attribute. If none were applied, this returns C<undef>. + +=item B<< $attr->has_applied_traits >> + +Returns true if this attribute has any traits applied. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native.pm b/lib/Moose/Meta/Attribute/Native.pm new file mode 100644 index 0000000..8307129 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native.pm @@ -0,0 +1,299 @@ +use strict; +use warnings; +package Moose::Meta::Attribute::Native; +our $VERSION = '2.1405'; + +use Module::Runtime 'require_module'; + +my @trait_names = qw(Bool Counter Number String Array Hash Code); + +for my $trait_name (@trait_names) { + my $trait_class = "Moose::Meta::Attribute::Native::Trait::$trait_name"; + my $meta = Class::MOP::Class->initialize( + "Moose::Meta::Attribute::Custom::Trait::$trait_name" + ); + + if ($meta->find_method_by_name('register_implementation')) { + my $class = $meta->name->register_implementation; + die "An implementation for $trait_name already exists " . + "(found '$class' when trying to register '$trait_class')" + } + $meta->add_method(register_implementation => sub { + # resolve_metatrait_alias will load classes anyway, but throws away + # their error message; we WANT to die if there's a problem + require_module($trait_class); + return $trait_class; + }); +} + +1; + +# ABSTRACT: Delegate to native Perl types + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native - Delegate to native Perl types + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyClass; + use Moose; + + has 'mapping' => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + exists_in_mapping => 'exists', + ids_in_mapping => 'keys', + get_mapping => 'get', + set_mapping => 'set', + set_quantity => [ set => 'quantity' ], + }, + ); + + my $obj = MyClass->new; + $obj->set_quantity(10); # quantity => 10 + $obj->set_mapping('foo', 4); # foo => 4 + $obj->set_mapping('bar', 5); # bar => 5 + $obj->set_mapping('baz', 6); # baz => 6 + + # prints 5 + print $obj->get_mapping('bar') if $obj->exists_in_mapping('bar'); + + # prints 'quantity, foo, bar, baz' + print join ', ', $obj->ids_in_mapping; + +=head1 DESCRIPTION + +Native delegations allow you to delegate to native Perl data +structures as if they were objects. For example, in the L</SYNOPSIS> you can +see a hash reference being treated as if it has methods named C<exists()>, +C<keys()>, C<get()>, and C<set()>. + +The delegation methods (mostly) map to Perl builtins and operators. The return +values of these delegations should be the same as the corresponding Perl +operation. Any deviations will be explicitly documented. + +=head1 API + +Native delegations are enabled by passing certain options to C<has> when +creating an attribute. + +=head2 traits + +To enable this feature, pass the appropriate name in the C<traits> array +reference for the attribute. For example, to enable this feature for hash +reference, we include C<'Hash'> in the list of traits. + +=head2 isa + +You will need to make sure that the attribute has an appropriate type. For +example, to use this with a Hash you must specify that your attribute is some +sort of C<HashRef>. + +=head2 handles + +This is just like any other delegation, but only a hash reference is allowed +when defining native delegations. The keys are the methods to be created in +the class which contains the attribute. The values are the methods provided by +the associated trait. Currying works the same way as it does with any other +delegation. + +See the docs for each native trait for details on what methods are available. + +=head1 TRAITS FOR NATIVE DELEGATIONS + +Below are some simple examples of each native trait. More features are +available than what is shown here; this is just a quick synopsis. + +=over + +=item Array (L<Moose::Meta::Attribute::Native::Trait::Array>) + + has 'queue' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + add_item => 'push', + next_item => 'shift', + # ... + } + ); + +=item Bool (L<Moose::Meta::Attribute::Native::Trait::Bool>) + + has 'is_lit' => ( + traits => ['Bool'], + is => 'ro', + isa => 'Bool', + default => 0, + handles => { + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + # ... + } + ); + +=item Code (L<Moose::Meta::Attribute::Native::Trait::Code>) + + has 'callback' => ( + traits => ['Code'], + is => 'ro', + isa => 'CodeRef', + default => sub { + sub {'called'} + }, + handles => { + call => 'execute', + # ... + } + ); + +=item Counter (L<Moose::Meta::Attribute::Native::Trait::Counter>) + + has 'counter' => ( + traits => ['Counter'], + is => 'ro', + isa => 'Num', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + reset_counter => 'reset', + # ... + } + ); + +=item Hash (L<Moose::Meta::Attribute::Native::Trait::Hash>) + + has 'options' => ( + traits => ['Hash'], + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + set_option => 'set', + get_option => 'get', + has_option => 'exists', + # ... + } + ); + +=item Number (L<Moose::Meta::Attribute::Native::Trait::Number>) + + has 'integer' => ( + traits => ['Number'], + is => 'ro', + isa => 'Int', + default => 5, + handles => { + set => 'set', + add => 'add', + sub => 'sub', + mul => 'mul', + div => 'div', + mod => 'mod', + abs => 'abs', + # ... + } + ); + +=item String (L<Moose::Meta::Attribute::Native::Trait::String>) + + has 'text' => ( + traits => ['String'], + is => 'ro', + isa => 'Str', + default => q{}, + handles => { + add_text => 'append', + replace_text => 'replace', + # ... + } + ); + +=back + +=head1 COMPATIBILITY WITH MooseX::AttributeHelpers + +This feature used to be a separated CPAN distribution called +L<MooseX::AttributeHelpers>. + +When the feature was incorporated into the Moose core, some of the API details +were changed. The underlying capabilities are the same, but some details of +the API were changed. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm new file mode 100644 index 0000000..d61ce06 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -0,0 +1,244 @@ +package Moose::Meta::Attribute::Native::Trait; +our $VERSION = '2.1405'; + +use Moose::Role; +use Module::Runtime 'require_module'; +use Moose::Deprecated; +use Moose::Util 'throw_exception'; +use Moose::Util::TypeConstraints; + +requires '_helper_type'; + +before '_process_options' => sub { + my ( $self, $name, $options ) = @_; + + $self->_check_helper_type( $options, $name ); +}; + +sub _check_helper_type { + my ( $self, $options, $name ) = @_; + + my $type = $self->_helper_type; + + $options->{isa} = $type + unless exists $options->{isa}; + + my $isa; + my $isa_name; + + if ( blessed( $options->{isa} ) + && $options->{isa}->can('does') + && $options->{isa}->does('Specio::Constraint::Role::Interface') ) { + + $isa = $options->{isa}; + require Specio::Library::Builtins; + return if $isa->is_a_type_of( Specio::Library::Builtins::t($type) ); + $isa_name = $isa->name() || $isa->description(); + } + else { + $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{isa} ); + return if $isa->is_a_type_of($type); + $isa_name = $isa->name(); + } + + throw_exception( WrongTypeConstraintGiven => required_type => $type, + given_type => $isa_name, + attribute_name => $name, + params => $options + ); +} + +before 'install_accessors' => sub { (shift)->_check_handles_values }; + +sub _check_handles_values { + my $self = shift; + + my %handles = $self->_canonicalize_handles; + + for my $original_method ( values %handles ) { + my $name = $original_method->[0]; + + my $accessor_class = $self->_native_accessor_class_for($name); + + ( $accessor_class && $accessor_class->can('new') ) + || confess + "$name is an unsupported method type - $accessor_class"; + } +} + +around '_canonicalize_handles' => sub { + shift; + my $self = shift; + my $handles = $self->handles; + + return unless $handles; + + unless ( 'HASH' eq ref $handles ) { + throw_exception( HandlesMustBeAHashRef => instance => $self, + given_handles => $handles + ); + } + + return + map { $_ => $self->_canonicalize_handles_value( $handles->{$_} ) } + keys %$handles; +}; + +sub _canonicalize_handles_value { + my $self = shift; + my $value = shift; + + if ( ref $value && 'ARRAY' ne ref $value ) { + throw_exception( InvalidHandleValue => instance => $self, + handle_value => $value + ); + } + + return ref $value ? $value : [$value]; +} + +around '_make_delegation_method' => sub { + my $next = shift; + my ( $self, $handle_name, $method_to_call ) = @_; + + my ( $name, @curried_args ) = @$method_to_call; + + my $accessor_class = $self->_native_accessor_class_for($name); + + die "Cannot find an accessor class for $name" + unless $accessor_class && $accessor_class->can('new'); + + return $accessor_class->new( + name => $handle_name, + package_name => $self->associated_class->name, + delegate_to_method => $name, + attribute => $self, + is_inline => 1, + curried_arguments => \@curried_args, + root_types => [ $self->_root_types ], + ); +}; + +sub _root_types { + return $_[0]->_helper_type; +} + +sub _native_accessor_class_for { + my ( $self, $suffix ) = @_; + + my $role + = 'Moose::Meta::Method::Accessor::Native::' + . $self->_native_type . '::' + . $suffix; + + require_module($role); + return Moose::Meta::Class->create_anon_class( + superclasses => + [ $self->accessor_metaclass, $self->delegation_metaclass ], + roles => [$role], + cache => 1, + )->name; +} + +sub _build_native_type { + my $self = shift; + + for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { + return $1 if $role_name =~ /::Native::Trait::(\w+)$/; + } + + throw_exception( CannotCalculateNativeType => instance => $self ); +} + +has '_native_type' => ( + is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_native_type', +); + +no Moose::Role; +no Moose::Util::TypeConstraints; + +1; + +# ABSTRACT: Shared role for native delegation traits + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait - Shared role for native delegation traits + +=head1 VERSION + +version 2.1405 + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 SEE ALSO + +Documentation for Moose native traits can be found in +L<Moose::Meta::Attribute::Native>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm new file mode 100644 index 0000000..3d33b08 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm @@ -0,0 +1,384 @@ +package Moose::Meta::Attribute::Native::Trait::Array; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'ArrayRef' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for ArrayRef attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Array - Helper trait for ArrayRef attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Stuff; + use Moose; + + has 'options' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + all_options => 'elements', + add_option => 'push', + map_options => 'map', + filter_options => 'grep', + find_option => 'first', + get_option => 'get', + join_options => 'join', + count_options => 'count', + has_options => 'count', + has_no_options => 'is_empty', + sorted_options => 'sort', + }, + ); + + no Moose; + 1; + +=head1 DESCRIPTION + +This trait provides native delegation methods for array references. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<ArrayRef>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<count> + +Returns the number of elements in the array. + + $stuff = Stuff->new; + $stuff->options( [ "foo", "bar", "baz", "boo" ] ); + + print $stuff->count_options; # prints 4 + +This method does not accept any arguments. + +=item * B<is_empty> + +Returns a boolean value that is true when the array has no elements. + + $stuff->has_no_options ? die "No options!\n" : print "Good boy.\n"; + +This method does not accept any arguments. + +=item * B<elements> + +Returns all of the elements of the array as an array (not an array reference). + + my @option = $stuff->all_options; + print "@options\n"; # prints "foo bar baz boo" + +This method does not accept any arguments. + +=item * B<get($index)> + +Returns an element of the array by its index. You can also use negative index +numbers, just as with Perl's core array handling. + + my $option = $stuff->get_option(1); + print "$option\n"; # prints "bar" + +If the specified element does not exist, this will return C<undef>. + +This method accepts just one argument. + +=item * B<pop> + +Just like Perl's builtin C<pop>. + +This method does not accept any arguments. + +=item * B<push($value1, $value2, value3 ...)> + +Just like Perl's builtin C<push>. Returns the number of elements in the new +array. + +This method accepts any number of arguments. + +=item * B<shift> + +Just like Perl's builtin C<shift>. + +This method does not accept any arguments. + +=item * B<unshift($value1, $value2, value3 ...)> + +Just like Perl's builtin C<unshift>. Returns the number of elements in the new +array. + +This method accepts any number of arguments. + +=item * B<splice($offset, $length, @values)> + +Just like Perl's builtin C<splice>. In scalar context, this returns the last +element removed, or C<undef> if no elements were removed. In list context, +this returns all the elements removed from the array. + +This method requires at least one argument. + +=item * B<first( sub { ... } )> + +This method returns the first matching item in the array, just like +L<List::Util>'s C<first> function. The matching is done with a subroutine +reference you pass to this method. The subroutine will be called against each +element in the array until one matches or all elements have been checked. +Each list element will be available to the sub in C<$_>. + + my $found = $stuff->find_option( sub {/^b/} ); + print "$found\n"; # prints "bar" + +This method requires a single argument. + +=item * B<first_index( sub { ... } )> + +This method returns the index of the first matching item in the array, just +like L<List::MoreUtils>'s C<first_index> function. The matching is done with a +subroutine reference you pass to this method. The subroutine will be called +against each element in the array until one matches or all elements have been +checked. Each list element will be available to the sub in C<$_>. + +This method requires a single argument. + +=item * B<grep( sub { ... } )> + +This method returns every element matching a given criteria, just like Perl's +core C<grep> function. This method requires a subroutine which implements the +matching logic; each list element will be available to the sub in C<$_>. + + my @found = $stuff->filter_options( sub {/^b/} ); + print "@found\n"; # prints "bar baz boo" + +This method requires a single argument. + +=item * B<map( sub { ... } )> + +This method transforms every element in the array and returns a new array, +just like Perl's core C<map> function. This method requires a subroutine which +implements the transformation; each list element will be available to the sub +in C<$_>. + + my @mod_options = $stuff->map_options( sub { $_ . "-tag" } ); + print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" + +This method requires a single argument. + +=item * B<reduce( sub { ... } )> + +This method turns an array into a single value, by passing a function the +value so far and the next value in the array, just like L<List::Util>'s +C<reduce> function. The reducing is done with a subroutine reference you pass +to this method; each list element will be available to the sub in C<$_>. + + my $found = $stuff->reduce_options( sub { $_[0] . $_[1] } ); + print "$found\n"; # prints "foobarbazboo" + +This method requires a single argument. + +=item * B<sort> + +=item * B<sort( sub { ... } )> + +Returns the elements of the array (not an array reference) in sorted order, +or, like C<elements>, returns the number of elements in the array in scalar context. + +You can provide an optional subroutine reference to sort with (as you can with +Perl's core C<sort> function). However, instead of using C<$a> and C<$b> in +this subroutine, you will need to use C<$_[0]> and C<$_[1]>. + + # ascending ASCIIbetical + my @sorted = $stuff->sort_options(); + + # Descending alphabetical order + my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } ); + print "@sorted_options\n"; # prints "foo boo baz bar" + +This method accepts a single argument. + +=item * B<sort_in_place> + +=item * B<sort_in_place( sub { ... } )> + +Sorts the array I<in place>, modifying the value of the attribute. + +You can provide an optional subroutine reference to sort with (as you can with +Perl's core C<sort> function). However, instead of using C<$a> and C<$b>, you +will need to use C<$_[0]> and C<$_[1]> instead. + +This method does not define a return value. + +This method accepts a single argument. + +=item * B<shuffle> + +Returns the elements of the array in random order, like C<shuffle> from +L<List::Util>. + +This method does not accept any arguments. + +=item * B<uniq> + +Returns the array with all duplicate elements removed, like C<uniq> from +L<List::MoreUtils>. + +This method does not accept any arguments. + +=item * B<join($str)> + +Joins every element of the array using the separator given as argument, just +like Perl's core C<join> function. + + my $joined = $stuff->join_options(':'); + print "$joined\n"; # prints "foo:bar:baz:boo" + +This method requires a single argument. + +=item * B<set($index, $value)> + +Given an index and a value, sets the specified array element's value. + +This method returns the value at C<$index> after the set. + +This method requires two arguments. + +=item * B<delete($index)> + +Removes the element at the given index from the array. + +This method returns the deleted value. Note that if no value exists, it will +return C<undef>. + +This method requires one argument. + +=item * B<insert($index, $value)> + +Inserts a new element into the array at the given index. + +This method returns the new value at C<$index>. + +This method requires two arguments. + +=item * B<clear> + +Empties the entire array, like C<@array = ()>. + +This method does not define a return value. + +This method does not accept any arguments. + +=item * B<accessor($index)> + +=item * B<accessor($index, $value)> + +This method provides a get/set accessor for the array, based on array indexes. +If passed one argument, it returns the value at the specified index. If +passed two arguments, it sets the value of the specified index. + +When called as a setter, this method returns the new value at C<$index>. + +This method accepts one or two arguments. + +=item * B<natatime($n)> + +=item * B<natatime($n, $code)> + +This method returns an iterator which, on each call, returns C<$n> more items +from the array, in order, like C<natatime> from L<List::MoreUtils>. + +If you pass a coderef as the second argument, then this code ref will be +called on each group of C<$n> elements in the array until the array is +exhausted. + +This method accepts one or two arguments. + +=item * B<shallow_clone> + +This method returns a shallow clone of the array reference. The return value +is a reference to a new array with the same elements. It is I<shallow> +because any elements that were references in the original will be the I<same> +references in the clone. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Bool.pm b/lib/Moose/Meta/Attribute/Native/Trait/Bool.pm new file mode 100644 index 0000000..d228d0b --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Bool.pm @@ -0,0 +1,146 @@ +package Moose::Meta::Attribute::Native::Trait::Bool; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Bool' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Bool attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Bool - Helper trait for Bool attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Room; + use Moose; + + has 'is_lit' => ( + traits => ['Bool'], + is => 'rw', + isa => 'Bool', + default => 0, + handles => { + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + }, + ); + + my $room = Room->new(); + $room->illuminate; # same as $room->is_lit(1); + $room->darken; # same as $room->is_lit(0); + $room->flip_switch; # same as $room->is_lit(not $room->is_lit); + return $room->is_dark; # same as !$room->is_lit + +=head1 DESCRIPTION + +This trait provides native delegation methods for boolean values. A boolean is +a scalar which can be C<1>, C<0>, C<"">, or C<undef>. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Bool>. + +=head1 PROVIDED METHODS + +None of these methods accept arguments. + +=over 4 + +=item * B<set> + +Sets the value to C<1> and returns C<1>. + +=item * B<unset> + +Set the value to C<0> and returns C<0>. + +=item * B<toggle> + +Toggles the value. If it's true, set to false, and vice versa. + +Returns the new value. + +=item * B<not> + +Equivalent of 'not C<$value>'. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Code.pm b/lib/Moose/Meta/Attribute/Native/Trait/Code.pm new file mode 100644 index 0000000..a0b90b3 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Code.pm @@ -0,0 +1,129 @@ +package Moose::Meta::Attribute::Native::Trait::Code; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'CodeRef' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for CodeRef attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Code - Helper trait for CodeRef attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Foo; + use Moose; + + has 'callback' => ( + traits => ['Code'], + is => 'ro', + isa => 'CodeRef', + default => sub { + sub { print "called" } + }, + handles => { + call => 'execute', + }, + ); + + my $foo = Foo->new; + $foo->call; # prints "called" + +=head1 DESCRIPTION + +This trait provides native delegation methods for code references. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<CodeRef>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<execute(@args)> + +Calls the coderef with the given args. + +=item * B<execute_method(@args)> + +Calls the coderef with the instance as invocant and given args. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Counter.pm b/lib/Moose/Meta/Attribute/Native/Trait/Counter.pm new file mode 100644 index 0000000..2677f88 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Counter.pm @@ -0,0 +1,157 @@ +package Moose::Meta::Attribute::Native::Trait::Counter; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Num' } +sub _root_types { 'Num', 'Int' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Int attributes which represent counters + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Counter - Helper trait for Int attributes which represent counters + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyHomePage; + use Moose; + + has 'counter' => ( + traits => ['Counter'], + is => 'ro', + isa => 'Num', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + reset_counter => 'reset', + }, + ); + + my $page = MyHomePage->new(); + $page->inc_counter; # same as $page->counter( $page->counter + 1 ); + $page->dec_counter; # same as $page->counter( $page->counter - 1 ); + + my $count_by_twos = 2; + $page->inc_counter($count_by_twos); + +=head1 DESCRIPTION + +This trait provides native delegation methods for counters. A counter can be +any sort of number (integer or not). The delegation methods allow you to +increment, decrement, or reset the value. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Num>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<set($value)> + +Sets the counter to the specified value and returns the new value. + +This method requires a single argument. + +=item * B<inc> + +=item * B<inc($arg)> + +Increases the attribute value by the amount of the argument, or by 1 if no +argument is given. This method returns the new value. + +This method accepts a single argument. + +=item * B<dec> + +=item * B<dec($arg)> + +Decreases the attribute value by the amount of the argument, or by 1 if no +argument is given. This method returns the new value. + +This method accepts a single argument. + +=item * B<reset> + +Resets the value stored in this slot to its default value, and returns the new +value. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Hash.pm b/lib/Moose/Meta/Attribute/Native/Trait/Hash.pm new file mode 100644 index 0000000..25fbc6b --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Hash.pm @@ -0,0 +1,226 @@ +package Moose::Meta::Attribute::Native::Trait::Hash; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'HashRef' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for HashRef attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Hash - Helper trait for HashRef attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Stuff; + use Moose; + + has 'options' => ( + traits => ['Hash'], + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + set_option => 'set', + get_option => 'get', + has_no_options => 'is_empty', + num_options => 'count', + delete_option => 'delete', + option_pairs => 'kv', + }, + ); + +=head1 DESCRIPTION + +This trait provides native delegation methods for hash references. + +=head1 PROVIDED METHODS + +=over 4 + +=item B<get($key, $key2, $key3...)> + +Returns values from the hash. + +In list context it returns a list of values in the hash for the given keys. In +scalar context it returns the value for the last key specified. + +This method requires at least one argument. + +=item B<set($key =E<gt> $value, $key2 =E<gt> $value2...)> + +Sets the elements in the hash to the given values. It returns the new values +set for each key, in the same order as the keys passed to the method. + +This method requires at least two arguments, and expects an even number of +arguments. + +=item B<delete($key, $key2, $key3...)> + +Removes the elements with the given keys. + +In list context it returns a list of values in the hash for the deleted +keys. In scalar context it returns the value for the last key specified. + +=item B<keys> + +Returns the list of keys in the hash. + +This method does not accept any arguments. + +=item B<exists($key)> + +Returns true if the given key is present in the hash. + +This method requires a single argument. + +=item B<defined($key)> + +Returns true if the value of a given key is defined. + +This method requires a single argument. + +=item B<values> + +Returns the list of values in the hash. + +This method does not accept any arguments. + +=item B<kv> + +Returns the key/value pairs in the hash as an array of array references. + + for my $pair ( $object->option_pairs ) { + print "$pair->[0] = $pair->[1]\n"; + } + +This method does not accept any arguments. + +=item B<elements> + +Returns the key/value pairs in the hash as a flattened list.. + +This method does not accept any arguments. + +=item B<clear> + +Resets the hash to an empty value, like C<%hash = ()>. + +This method does not accept any arguments. + +=item B<count> + +Returns the number of elements in the hash. Also useful to check for a nonempty hash, because C<count> returns a true (nonzero) value if there is something in the hash: +C<< has_options => 'count' >>. + +This method does not accept any arguments. + +=item B<is_empty> + +If the hash is populated, returns false. Otherwise, returns true. + +This method does not accept any arguments. + +=item B<accessor($key)> + +=item B<accessor($key, $value)> + +If passed one argument, returns the value of the specified key. If passed two +arguments, sets the value of the specified key. + +When called as a setter, this method returns the value that was set. + +=item B<shallow_clone> + +This method returns a shallow clone of the hash reference. The return value +is a reference to a new hash with the same keys and values. It is I<shallow> +because any values that were references in the original will be the I<same> +references in the clone. + +=back + +Note that C<each> is deliberately omitted, due to its stateful interaction +with the hash iterator. C<keys> or C<kv> are much safer. + +=head1 METHODS + +=over 4 + +=item B<meta> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Number.pm b/lib/Moose/Meta/Attribute/Native/Trait/Number.pm new file mode 100644 index 0000000..4851246 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Number.pm @@ -0,0 +1,155 @@ +package Moose::Meta::Attribute::Native::Trait::Number; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Num' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Num attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Number - Helper trait for Num attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Real; + use Moose; + + has 'integer' => ( + traits => ['Number'], + is => 'ro', + isa => 'Num', + default => 5, + handles => { + set => 'set', + add => 'add', + sub => 'sub', + mul => 'mul', + div => 'div', + mod => 'mod', + abs => 'abs', + }, + ); + + my $real = Real->new(); + $real->add(5); # same as $real->integer($real->integer + 5); + $real->sub(2); # same as $real->integer($real->integer - 2); + +=head1 DESCRIPTION + +This trait provides native delegation methods for numbers. All of the +operations correspond to arithmetic operations like addition or +multiplication. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Num>. + +=head1 PROVIDED METHODS + +All of these methods modify the attribute's value in place. All methods return +the new value. + +=over 4 + +=item * B<add($value)> + +Adds the current value of the attribute to C<$value>. + +=item * B<sub($value)> + +Subtracts C<$value> from the current value of the attribute. + +=item * B<mul($value)> + +Multiplies the current value of the attribute by C<$value>. + +=item * B<div($value)> + +Divides the current value of the attribute by C<$value>. + +=item * B<mod($value)> + +Returns the current value of the attribute modulo C<$value>. + +=item * B<abs> + +Sets the current value of the attribute to its absolute value. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/String.pm b/lib/Moose/Meta/Attribute/Native/Trait/String.pm new file mode 100644 index 0000000..c919f3a --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/String.pm @@ -0,0 +1,187 @@ +package Moose::Meta::Attribute::Native::Trait::String; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Str' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Str attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::String - Helper trait for Str attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyHomePage; + use Moose; + + has 'text' => ( + traits => ['String'], + is => 'rw', + isa => 'Str', + default => q{}, + handles => { + add_text => 'append', + replace_text => 'replace', + }, + ); + + my $page = MyHomePage->new(); + $page->add_text("foo"); # same as $page->text($page->text . "foo"); + +=head1 DESCRIPTION + +This trait provides native delegation methods for strings. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Str>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<inc> + +Increments the value stored in this slot using the magical string autoincrement +operator. Note that Perl doesn't provide analogous behavior in C<-->, so +C<dec> is not available. This method returns the new value. + +This method does not accept any arguments. + +=item * B<append($string)> + +Appends to the string, like C<.=>, and returns the new value. + +This method requires a single argument. + +=item * B<prepend($string)> + +Prepends to the string and returns the new value. + +This method requires a single argument. + +=item * B<replace($pattern, $replacement)> + +Performs a regexp substitution (L<perlop/s>). There is no way to provide the +C<g> flag, but code references will be accepted for the replacement, causing +the regex to be modified with a single C<e>. C</smxi> can be applied using the +C<qr> operator. This method returns the new value. + +This method requires two arguments. + +=item * B<match($pattern)> + +Runs the regex against the string and returns the matching value(s). + +This method requires a single argument. + +=item * B<chop> + +Just like L<perlfunc/chop>. This method returns the chopped character. + +This method does not accept any arguments. + +=item * B<chomp> + +Just like L<perlfunc/chomp>. This method returns the number of characters +removed. + +This method does not accept any arguments. + +=item * B<clear> + +Sets the string to the empty string (not the value passed to C<default>). + +This method does not have a defined return value. + +This method does not accept any arguments. + +=item * B<length> + +Just like L<perlfunc/length>, returns the length of the string. + +=item * B<substr> + +This acts just like L<perlfunc/substr>. When called as a writer, it returns +the substring that was replaced, just like the Perl builtin. + +This method requires at least one argument, and accepts no more than three. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm new file mode 100644 index 0000000..fafd2c5 --- /dev/null +++ b/lib/Moose/Meta/Class.pm @@ -0,0 +1,1002 @@ +package Moose::Meta::Class; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP; +use Data::OptList; +use List::Util 1.33 qw( any first ); +use List::MoreUtils qw( uniq first_index ); +use Scalar::Util 'blessed'; + +use Moose::Meta::Method::Overridden; +use Moose::Meta::Method::Augmented; +use Moose::Meta::Class::Immutable::Trait; +use Moose::Meta::Method::Constructor; +use Moose::Meta::Method::Destructor; +use Moose::Meta::Method::Meta; +use Moose::Util 'throw_exception'; +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Class'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +__PACKAGE__->meta->add_attribute('roles' => ( + reader => 'roles', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('role_applications' => ( + reader => '_get_role_applications', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('immutable_trait' => ( + accessor => "immutable_trait", + default => 'Moose::Meta::Class::Immutable::Trait', + Class::MOP::_definition_context(), + )) +); + +__PACKAGE__->meta->add_attribute('constructor_class' => ( + accessor => 'constructor_class', + default => 'Moose::Meta::Method::Constructor', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('destructor_class' => ( + accessor => 'destructor_class', + default => 'Moose::Meta::Method::Destructor', + Class::MOP::_definition_context(), +)); + +sub initialize { + my $class = shift; + my @args = @_; + unshift @args, 'package' if @args % 2; + my %opts = @args; + my $package = delete $opts{package}; + return Class::MOP::get_metaclass_by_name($package) + || $class->SUPER::initialize($package, + 'attribute_metaclass' => 'Moose::Meta::Attribute', + 'method_metaclass' => 'Moose::Meta::Method', + 'instance_metaclass' => 'Moose::Meta::Instance', + %opts, + ); +} + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + (ref $options{roles} eq 'ARRAY') + || throw_exception( RolesInCreateTakesAnArrayRef => params => \%options ) + if exists $options{roles}; + + my $package = delete $options{package}; + my $roles = delete $options{roles}; + + my $new_meta = $class->SUPER::create($package, %options); + + if ($roles) { + Moose::Util::apply_all_roles( $new_meta, @$roles ); + } + + return $new_meta; +} + +sub _meta_method_class { 'Moose::Meta::Method::Meta' } + +sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + + my $superclass_key = join('|', + map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) } + ); + + my $roles = Data::OptList::mkopt(($options{roles} || []), { + moniker => 'role', + val_test => sub { ref($_[0]) eq 'HASH' }, + }); + + my @role_keys; + for my $role_spec (@$roles) { + my ($role, $params) = @$role_spec; + $params = { %$params } if $params; + + my $key = blessed($role) ? $role->name : $role; + + if ($params && %$params) { + my $alias = delete $params->{'-alias'} + || delete $params->{'alias'} + || {}; + my $excludes = delete $params->{'-excludes'} + || delete $params->{'excludes'} + || []; + $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; + + if (%$params) { + warn "Roles with parameters cannot be cached. Consider " + . "applying the parameters before calling " + . "create_anon_class, or using 'weaken => 0' instead"; + return; + } + + my $alias_key = join('%', + map { $_ => $alias->{$_} } sort keys %$alias + ); + my $excludes_key = join('%', + sort @$excludes + ); + $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; + } + + push @role_keys, $key; + } + + my $role_key = join('|', sort @role_keys); + + # Makes something like Super::Class|Super::Class::2=Role|Role::1 + return join('=', $superclass_key, $role_key); +} + +sub reinitialize { + my $self = shift; + my $pkg = shift; + + my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); + + my %existing_classes; + if ($meta) { + %existing_classes = map { $_ => $meta->$_() } qw( + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + ); + } + + return $self->SUPER::reinitialize( + $pkg, + %existing_classes, + @_, + ); +} + +sub add_role { + my ($self, $role) = @_; + (blessed($role) && $role->isa('Moose::Meta::Role')) + || throw_exception( AddRoleTakesAMooseMetaRoleInstance => role_to_be_added => $role, + class_name => $self->name, + ); + push @{$self->roles} => $role; +} + +sub role_applications { + my ($self) = @_; + + return @{$self->_get_role_applications}; +} + +sub add_role_application { + my ($self, $application) = @_; + + (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass')) + || throw_exception( InvalidRoleApplication => class_name => $self->name, + application => $application, + ); + + push @{$self->_get_role_applications} => $application; +} + +sub calculate_all_roles { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles }; +} + +sub _roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('roles') + ? @{ Class::MOP::class_of($_)->roles } + : () } + $self->linearized_isa; +} + +sub calculate_all_roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('calculate_all_roles') + ? Class::MOP::class_of($_)->calculate_all_roles + : () } + $self->linearized_isa; +} + +sub does_role { + my ($self, $role_name) = @_; + + (defined $role_name) + || throw_exception( RoleNameRequired => class_name => $self->name ); + + foreach my $class ($self->class_precedence_list) { + my $meta = Class::MOP::class_of($class); + # when a Moose metaclass is itself extended with a role, + # this check needs to be done since some items in the + # class_precedence_list might in fact be Class::MOP + # based still. + next unless $meta && $meta->can('roles'); + foreach my $role (@{$meta->roles}) { + return 1 if $role->does_role($role_name); + } + } + return 0; +} + +sub excludes_role { + my ($self, $role_name) = @_; + + (defined $role_name) + || throw_exception( RoleNameRequired => class_name => $self->name ); + + foreach my $class ($self->class_precedence_list) { + my $meta = Class::MOP::class_of($class); + # when a Moose metaclass is itself extended with a role, + # this check needs to be done since some items in the + # class_precedence_list might in fact be Class::MOP + # based still. + next unless $meta && $meta->can('roles'); + foreach my $role (@{$meta->roles}) { + return 1 if $role->excludes_role($role_name); + } + } + return 0; +} + +sub new_object { + my $self = shift; + my $params = @_ == 1 ? $_[0] : {@_}; + my $object = $self->SUPER::new_object($params); + + $self->_call_all_triggers($object, $params); + + $object->BUILDALL($params) if $object->can('BUILDALL'); + + return $object; +} + +sub _call_all_triggers { + my ($self, $object, $params) = @_; + + foreach my $attr ( $self->get_all_attributes() ) { + + next unless $attr->can('has_trigger') && $attr->has_trigger; + + my $init_arg = $attr->init_arg; + next unless defined $init_arg; + next unless exists $params->{$init_arg}; + + $attr->trigger->( + $object, + ( + $attr->should_coerce + ? $attr->get_read_method_ref->($object) + : $params->{$init_arg} + ), + ); + } +} + +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return $class . '->Moose::Object::new(@_)' +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = ', + $self->_inline_BUILDARGS($class, '@_'), + ';', + ); +} + +sub _inline_BUILDARGS { + my $self = shift; + my ($class, $args) = @_; + + my $buildargs = $self->find_method_by_name("BUILDARGS"); + + if ($args eq '@_' + && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) { + return ( + 'do {', + 'my $params;', + 'if (scalar @_ == 1) {', + 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {', + $self->_inline_throw_exception( + 'SingleParamsToNewMustBeHashRef' + ) . ';', + '}', + '$params = { %{ $_[0] } };', + '}', + 'elsif (@_ % 2) {', + 'Carp::carp(', + '"The new() method for ' . $class . ' expects a ' + . 'hash reference or a key/value list. You passed an ' + . 'odd number of arguments"', + ');', + '$params = {@_, undef};', + '}', + 'else {', + '$params = {@_};', + '}', + '$params;', + '}', + ); + } + else { + return $class . '->BUILDARGS(' . $args . ')'; + } +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $idx) = @_; + + return ( + '## ' . $attr->name, + $self->_inline_check_required_attr($attr), + $self->SUPER::_inline_slot_initializer(@_), + ); +} + +sub _inline_check_required_attr { + my $self = shift; + my ($attr) = @_; + + return unless defined $attr->init_arg; + return unless $attr->can('is_required') && $attr->is_required; + return if $attr->has_default || $attr->has_builder; + + return ( + 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_throw_exception( + AttributeIsRequired => + 'params => $params, '. + 'class_name => $class_name, '. + 'attribute_name => "'.quotemeta($attr->name).'"' + ).';', + '}', + ); +} + +# XXX: these two are duplicated from cmop, because we have to pass the tc stuff +# through to _inline_set_value - this should probably be fixed, but i'm not +# quite sure how. -doy +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', + '$params->{\'' . $attr->init_arg . '\'}', + '$type_constraint_bodies[' . $idx . ']', + '$type_coercions[' . $idx . ']', + '$type_constraint_messages[' . $idx . ']', + 'for constructor', + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $idx) = @_; + + return if $attr->can('is_lazy') && $attr->is_lazy; + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; + + my @initial_value = ( + 'my $default = ' . $default . ';', + $attr->_inline_set_value( + '$instance', + '$default', + '$type_constraint_bodies[' . $idx . ']', + '$type_coercions[' . $idx . ']', + '$type_constraint_messages[' . $idx . ']', + 'for constructor', + ), + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_extra_init { + my $self = shift; + return ( + $self->_inline_triggers, + $self->_inline_BUILDALL, + ); +} + +sub _inline_triggers { + my $self = shift; + my @trigger_calls; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + for my $i (0 .. $#attrs) { + my $attr = $attrs[$i]; + + next unless $attr->can('has_trigger') && $attr->has_trigger; + + my $init_arg = $attr->init_arg; + next unless defined $init_arg; + + push @trigger_calls, + 'if (exists $params->{\'' . $init_arg . '\'}) {', + '$triggers->[' . $i . ']->(', + '$instance,', + $attr->_inline_instance_get('$instance') . ',', + ');', + '}'; + } + + return @trigger_calls; +} + +sub _inline_BUILDALL { + my $self = shift; + + my @methods = reverse $self->find_all_methods_by_name('BUILD'); + my @BUILD_calls; + + foreach my $method (@methods) { + push @BUILD_calls, + '$instance->' . $method->{class} . '::BUILD($params);'; + } + + return @BUILD_calls; +} + +sub _eval_environment { + my $self = shift; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + + my $triggers = [ + map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef } + @attrs + ]; + + # We need to check if the attribute ->can('type_constraint') + # since we may be trying to immutabilize a Moose meta class, + # which in turn has attributes which are Class::MOP::Attribute + # objects, rather than Moose::Meta::Attribute. And + # Class::MOP::Attribute attributes have no type constraints. + # However we need to make sure we leave an undef value there + # because the inlined code is using the index of the attributes + # to determine where to find the type constraint + + my @type_constraints = map { + $_->can('type_constraint') ? $_->type_constraint : undef + } @attrs; + + my @type_constraint_bodies = map { + defined $_ ? $_->_compiled_type_constraint : undef; + } @type_constraints; + + my @type_coercions = map { + defined $_ && $_->has_coercion + ? $_->coercion->_compiled_type_coercion + : undef + } @type_constraints; + + my @type_constraint_messages = map { + defined $_ + ? ($_->has_message ? $_->message : $_->_default_message) + : undef + } @type_constraints; + + return { + %{ $self->SUPER::_eval_environment }, + ((any { defined && $_->has_initializer } @attrs) + ? ('$attrs' => \[@attrs]) + : ()), + '$triggers' => \$triggers, + '@type_coercions' => \@type_coercions, + '@type_constraint_bodies' => \@type_constraint_bodies, + '@type_constraint_messages' => \@type_constraint_messages, + ( map { defined($_) ? %{ $_->inline_environment } : () } + @type_constraints ), + # pretty sure this is only going to be closed over if you use a custom + # error class at this point, but we should still get rid of this + # at some point + '$meta' => \$self, + '$class_name' => \($self->name), + }; +} + +sub superclasses { + my $self = shift; + my $supers = Data::OptList::mkopt(\@_); + foreach my $super (@{ $supers }) { + my ($name, $opts) = @{ $super }; + Moose::Util::_load_user_class($name, $opts); + my $meta = Class::MOP::class_of($name); + throw_exception( CanExtendOnlyClasses => role_name => $meta->name ) + if $meta && $meta->isa('Moose::Meta::Role') + } + return $self->SUPER::superclasses(map { $_->[0] } @{ $supers }); +} + +### --------------------------------------------- + +sub add_attribute { + my $self = shift; + my $attr = + (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') + ? $_[0] + : $self->_process_attribute(@_)); + $self->SUPER::add_attribute($attr); + # it may be a Class::MOP::Attribute, theoretically, which doesn't have + # 'bare' and doesn't implement this method + if ($attr->can('_check_associated_methods')) { + $attr->_check_associated_methods; + } + return $attr; +} + +sub add_override_method_modifier { + my ($self, $name, $method, $_super_package) = @_; + + my $existing_method = $self->get_method($name); + (!$existing_method) + || throw_exception( CannotOverrideLocalMethodIsPresent => class_name => $self->name, + method => $existing_method, + ); + $self->add_method($name => Moose::Meta::Method::Overridden->new( + method => $method, + class => $self, + package => $_super_package, # need this for roles + name => $name, + )); +} + +sub add_augment_method_modifier { + my ($self, $name, $method) = @_; + my $existing_method = $self->get_method($name); + throw_exception( CannotAugmentIfLocalMethodPresent => class_name => $self->name, + method => $existing_method, + ) + if( $existing_method ); + + $self->add_method($name => Moose::Meta::Method::Augmented->new( + method => $method, + class => $self, + name => $name, + )); +} + +## Private Utility methods ... + +sub _find_next_method_by_name_which_is_not_overridden { + my ($self, $name) = @_; + foreach my $method ($self->find_all_methods_by_name($name)) { + return $method->{code} + if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden'); + } + return undef; +} + +## Metaclass compatibility + +sub _base_metaclasses { + my $self = shift; + my %metaclasses = $self->SUPER::_base_metaclasses; + for my $class (keys %metaclasses) { + $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/; + } + return ( + %metaclasses, + ); +} + +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ($super_meta) = @_; + + $self->SUPER::_fix_class_metaclass_incompatibility(@_); + + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { + ($self->is_pristine) + || throw_exception( CannotFixMetaclassCompatibility => class => $self, + superclass => $super_meta + ); + my $super_meta_name = $super_meta->_real_ref_name; + my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name); + my $new_self = $class_meta_subclass_meta_name->reinitialize( + $self->name, + ); + + $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); + } +} + +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ($metaclass_type, $super_meta) = @_; + + $self->SUPER::_fix_single_metaclass_incompatibility(@_); + + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || throw_exception( CannotFixMetaclassCompatibility => class => $self, + superclass => $super_meta, + metaclass_type => $metaclass_type + ); + my $super_meta_name = $super_meta->_real_ref_name; + my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); + my $new_self = $super_meta->reinitialize( + $self->name, + $metaclass_type => $class_specific_meta_subclass_meta_name, + ); + + $self->_replace_self( $new_self, $super_meta_name ); + } +} + +sub _replace_self { + my $self = shift; + my ( $new_self, $new_class) = @_; + + %$self = %$new_self; + bless $self, $new_class; + + # We need to replace the cached metaclass instance or else when it goes + # out of scope Class::MOP::Class destroy's the namespace for the + # metaclass's class, causing much havoc. + my $weaken = Class::MOP::metaclass_is_weak( $self->name ); + Class::MOP::store_metaclass_by_name( $self->name, $self ); + Class::MOP::weaken_metaclass( $self->name ) if $weaken; +} + +sub _process_attribute { + my ( $self, $name, @args ) = @_; + + @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; + + if (($name || '') =~ /^\+(.*)/) { + return $self->_process_inherited_attribute($1, @args); + } + else { + return $self->_process_new_attribute($name, @args); + } +} + +sub _process_new_attribute { + my ( $self, $name, @args ) = @_; + + $self->attribute_metaclass->interpolate_class_and_new($name, @args); +} + +sub _process_inherited_attribute { + my ($self, $attr_name, %options) = @_; + + my $inherited_attr = $self->find_attribute_by_name($attr_name); + (defined $inherited_attr) + || throw_exception( NoAttributeFoundInSuperClass => class_name => $self->name, + attribute_name => $attr_name, + params => \%options + ); + if ($inherited_attr->isa('Moose::Meta::Attribute')) { + return $inherited_attr->clone_and_inherit_options(%options); + } + else { + # NOTE: + # kind of a kludge to handle Class::MOP::Attributes + return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options); + } +} + +# reinitialization support + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->SUPER::_restore_metaobjects_from($old_meta); + + for my $role ( @{ $old_meta->roles } ) { + $self->add_role($role); + } + + for my $application ( @{ $old_meta->_get_role_applications } ) { + $application->class($self); + $self->add_role_application ($application); + } +} + +## Immutability + +sub _immutable_options { + my ( $self, @args ) = @_; + + $self->SUPER::_immutable_options( + inline_destructor => 1, + + # Moose always does this when an attribute is created + inline_accessors => 0, + + @args, + ); +} + +sub _fixup_attributes_after_rebless { + my $self = shift; + my ($instance, $rebless_from, %params) = @_; + + $self->SUPER::_fixup_attributes_after_rebless( + $instance, + $rebless_from, + %params + ); + + $self->_call_all_triggers( $instance, \%params ); +} + +## ------------------------------------------------- + +our $error_level; + +sub _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')'; +} + +1; + +# ABSTRACT: The Moose metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Class - The Moose metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Class> that provides +additional Moose-specific functionality. + +To really understand this class, you will need to start with the +L<Class::MOP::Class> documentation. This class can be understood as a +set of additional features on top of the basic feature provided by +that parent class. + +=head1 INHERITANCE + +C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Class->initialize($package_name, %options) >> + +This overrides the parent's method in order to provide its own +defaults for the C<attribute_metaclass>, C<instance_metaclass>, and +C<method_metaclass> options. + +These all default to the appropriate Moose class. + +=item B<< Moose::Meta::Class->create($package_name, %options) >> + +This overrides the parent's method in order to accept a C<roles> +option. This should be an array reference containing roles +that the class does, each optionally followed by a hashref of options +(C<-excludes> and C<-alias>). + + my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); + +=item B<< Moose::Meta::Class->create_anon_class >> + +This overrides the parent's method to accept a C<roles> option, just +as C<create> does. + +It also accepts a C<cache> option. If this is C<true>, then the anonymous +class will be cached based on its superclasses and roles. If an +existing anonymous class in the cache has the same superclasses and +roles, it will be reused. + + my $metaclass = Moose::Meta::Class->create_anon_class( + superclasses => ['Foo'], + roles => [qw/Some Roles Go Here/], + cache => 1, + ); + +Each entry in both the C<superclasses> and the C<roles> option can be +followed by a hash reference with arguments. The C<superclasses> +option can be supplied with a L<-version|Class::MOP/Class Loading +Options> option that ensures the loaded superclass satisfies the +required version. The C<role> option also takes the C<-version> as an +argument, but the option hash reference can also contain any other +role relevant values like exclusions or parameterized role arguments. + +=item B<< $metaclass->new_object(%params) >> + +This overrides the parent's method in order to add support for +attribute triggers. + +=item B<< $metaclass->superclasses(@superclasses) >> + +This is the accessor allowing you to read or change the parents of +the class. + +Each superclass can be followed by a hash reference containing a +L<-version|Class::MOP/Class Loading Options> value. If the version +requirement is not satisfied an error will be thrown. + +When you pass classes to this method, we will attempt to load them if they are +not already loaded. + +=item B<< $metaclass->add_override_method_modifier($name, $sub) >> + +This adds an C<override> method modifier to the package. + +=item B<< $metaclass->add_augment_method_modifier($name, $sub) >> + +This adds an C<augment> method modifier to the package. + +=item B<< $metaclass->calculate_all_roles >> + +This will return a unique array of L<Moose::Meta::Role> instances +which are attached to this class. + +=item B<< $metaclass->calculate_all_roles_with_inheritance >> + +This will return a unique array of L<Moose::Meta::Role> instances +which are attached to this class, and each of this class's ancestors. + +=item B<< $metaclass->add_role($role) >> + +This takes a L<Moose::Meta::Role> object, and adds it to the class's +list of roles. This I<does not> actually apply the role to the class. + +=item B<< $metaclass->role_applications >> + +Returns a list of L<Moose::Meta::Role::Application::ToClass> +objects, which contain the arguments to role application. + +=item B<< $metaclass->add_role_application($application) >> + +This takes a L<Moose::Meta::Role::Application::ToClass> object, and +adds it to the class's list of role applications. This I<does not> +actually apply any role to the class; it is only for tracking role +applications. + +=item B<< $metaclass->does_role($role) >> + +This returns a boolean indicating whether or not the class does the specified +role. The role provided can be either a role name or a L<Moose::Meta::Role> +object. This tests both the class and its parents. + +=item B<< $metaclass->excludes_role($role_name) >> + +A class excludes a role if it has already composed a role which +excludes the named role. This tests both the class and its parents. + +=item B<< $metaclass->add_attribute($attr_name, %params|$params) >> + +This overrides the parent's method in order to allow the parameters to +be provided as a hash reference. + +=item B<< $metaclass->constructor_class($class_name) >> + +=item B<< $metaclass->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. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Class/Immutable/Trait.pm b/lib/Moose/Meta/Class/Immutable/Trait.pm new file mode 100644 index 0000000..8dba57a --- /dev/null +++ b/lib/Moose/Meta/Class/Immutable/Trait.pm @@ -0,0 +1,123 @@ +package Moose::Meta::Class::Immutable::Trait; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP; +use Scalar::Util qw( blessed ); + +use parent 'Class::MOP::Class::Immutable::Trait'; + +use Moose::Util 'throw_exception'; + +sub add_role { $_[1]->_immutable_cannot_call } + +sub calculate_all_roles { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{calculate_all_roles} ||= [ $self->$orig ] }; +} + +sub calculate_all_roles_with_inheritance { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{calculate_all_roles_with_inheritance} ||= [ $self->$orig ] }; +} + +sub does_role { + shift; + my $self = shift; + my $role = shift; + + (defined $role) + || throw_exception( RoleNameRequired => class_name => $self->name ); + + $self->{__immutable}{does_role} ||= { map { $_->name => 1 } $self->calculate_all_roles_with_inheritance }; + + my $name = blessed $role ? $role->name : $role; + + return $self->{__immutable}{does_role}{$name}; +} + +1; + +# ABSTRACT: Implements immutability for metaclass objects + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Class::Immutable::Trait - Implements immutability for metaclass objects + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class makes some Moose-specific metaclass methods immutable. This +is deep guts. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Instance.pm b/lib/Moose/Meta/Instance.pm new file mode 100644 index 0000000..ee412b4 --- /dev/null +++ b/lib/Moose/Meta/Instance.pm @@ -0,0 +1,109 @@ +package Moose::Meta::Instance; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Instance'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +1; + +# ABSTRACT: The Moose Instance metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Instance - The Moose Instance metaclass + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + # nothing to see here + +=head1 DESCRIPTION + +This class provides the low level data storage abstractions for +attributes. + +Using this API directly in your own code violates encapsulation, and +we recommend that you use the appropriate APIs in +L<Moose::Meta::Class> and L<Moose::Meta::Attribute> instead. Those +APIs in turn call the methods in this class as appropriate. + +At present, this is an empty subclass of L<Class::MOP::Instance>, so +you should see that class for all API details. + +=head1 INHERITANCE + +C<Moose::Meta::Instance> is a subclass of L<Class::MOP::Instance>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method.pm b/lib/Moose/Meta/Method.pm new file mode 100644 index 0000000..e0bc667 --- /dev/null +++ b/lib/Moose/Meta/Method.pm @@ -0,0 +1,100 @@ +package Moose::Meta::Method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Method'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +1; + +# ABSTRACT: A Moose Method metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method - A Moose Method metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method> that provides +additional Moose-specific functionality, all of which is private. + +To understand this class, you should read the the L<Class::MOP::Method> +documentation. + +=head1 INHERITANCE + +C<Moose::Meta::Method> is a subclass of L<Class::MOP::Method>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm new file mode 100644 index 0000000..3b30b2d --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -0,0 +1,208 @@ +package Moose::Meta::Method::Accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Try::Tiny; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Accessor'; + +use Moose::Util 'throw_exception'; + +# multiple inheritance is terrible +sub new { + goto &Class::MOP::Method::Accessor::new; +} + +sub _new { + goto &Class::MOP::Method::Accessor::_new; +} + +sub _error_thrower { + my $self = shift; + return $self->associated_attribute + if ref($self) && defined($self->associated_attribute); + return $self->SUPER::_error_thrower; +} + +sub _compile_code { + my $self = shift; + my @args = @_; + try { + $self->SUPER::_compile_code(@args); + } + catch { + throw_exception( CouldNotCreateWriter => attribute => $self->associated_attribute, + error => $_, + instance => $self + ); + }; +} + +sub _eval_environment { + my $self = shift; + return $self->associated_attribute->_eval_environment; +} + +sub _instance_is_inlinable { + my $self = shift; + return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable; +} + +sub _generate_reader_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_) + : $self->SUPER::_generate_reader_method(@_); +} + +sub _generate_writer_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_) + : $self->SUPER::_generate_writer_method(@_); +} + +sub _generate_accessor_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_) + : $self->SUPER::_generate_accessor_method(@_); +} + +sub _generate_predicate_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_) + : $self->SUPER::_generate_predicate_method(@_); +} + +sub _generate_clearer_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_) + : $self->SUPER::_generate_clearer_method(@_); +} + +sub _writer_value_needs_copy { + shift->associated_attribute->_writer_value_needs_copy(@_); +} + +sub _inline_tc_code { + shift->associated_attribute->_inline_tc_code(@_); +} + +sub _inline_check_coercion { + shift->associated_attribute->_inline_check_coercion(@_); +} + +sub _inline_check_constraint { + shift->associated_attribute->_inline_check_constraint(@_); +} + +sub _inline_check_lazy { + shift->associated_attribute->_inline_check_lazy(@_); +} + +sub _inline_store_value { + shift->associated_attribute->_inline_instance_set(@_) . ';'; +} + +sub _inline_get_old_value_for_trigger { + shift->associated_attribute->_inline_get_old_value_for_trigger(@_); +} + +sub _inline_trigger { + shift->associated_attribute->_inline_trigger(@_); +} + +sub _get_value { + shift->associated_attribute->_inline_instance_get(@_); +} + +sub _has_value { + shift->associated_attribute->_inline_instance_has(@_); +} + +1; + +# ABSTRACT: A Moose Method metaclass for accessors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Accessor> that +provides additional Moose-specific functionality, all of which is +private. + +To understand this class, you should read the the +L<Class::MOP::Method::Accessor> documentation. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Accessor/Native.pm b/lib/Moose/Meta/Method/Accessor/Native.pm new file mode 100644 index 0000000..01a3fee --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native.pm @@ -0,0 +1,157 @@ +package Moose::Meta::Method::Accessor::Native; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Carp qw( confess ); +use Scalar::Util qw( blessed ); + +use Moose::Role; + +use Moose::Util 'throw_exception'; + +around new => sub { + my $orig = shift; + my $class = shift; + my %options = @_; + + $options{curried_arguments} = [] + unless exists $options{curried_arguments}; + + throw_exception( MustSupplyArrayRefAsCurriedArguments => params => \%options, + class_name => $class + ) + unless $options{curried_arguments} + && ref($options{curried_arguments}) eq 'ARRAY'; + + my $attr_context = $options{attribute}->definition_context; + my $desc = 'native delegation method '; + $desc .= $options{attribute}->associated_class->name; + $desc .= '::' . $options{name}; + $desc .= " ($options{delegate_to_method})"; + $desc .= " of attribute " . $options{attribute}->name; + $options{definition_context} = { + %{ $attr_context || {} }, + description => $desc, + }; + + $options{accessor_type} = 'native'; + + return $class->$orig(%options); +}; + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless $options, $class; +} + +sub root_types { (shift)->{'root_types'} } + +sub _initialize_body { + my $self = shift; + + $self->{'body'} = $self->_compile_code( [$self->_generate_method] ); + + return; +} + +sub _inline_curried_arguments { + my $self = shift; + + return unless @{ $self->curried_arguments }; + + return 'unshift @_, @curried;'; +} + +sub _inline_check_argument_count { + my $self = shift; + + my @code; + + if (my $min = $self->_minimum_arguments) { + push @code, ( + 'if (@_ < ' . $min . ') {', + $self->_inline_throw_exception( MethodExpectsMoreArgs => + 'method_name => "'.$self->delegate_to_method.'",'. + "minimum_args => ".$min, + ) . ';', + '}', + ); + } + + if (defined(my $max = $self->_maximum_arguments)) { + push @code, ( + 'if (@_ > ' . $max . ') {', + $self->_inline_throw_exception( MethodExpectsFewerArgs => + 'method_name => "'.$self->delegate_to_method.'",'. + 'maximum_args => '.$max, + ) . ';', + '}', + ); + } + + return @code; +} + +sub _inline_return_value { + my $self = shift; + my ($slot_access, $for_writer) = @_; + + return 'return ' . $self->_return_value($slot_access, $for_writer) . ';'; +} + +sub _minimum_arguments { 0 } +sub _maximum_arguments { undef } + +override _get_value => sub { + my $self = shift; + my ($instance) = @_; + + return $self->_slot_access_can_be_inlined + ? super() + : $instance . '->$reader'; +}; + +override _inline_store_value => sub { + my $self = shift; + my ($instance, $value) = @_; + + return $self->_slot_access_can_be_inlined + ? super() + : $instance . '->$writer(' . $value . ');'; +}; + +override _eval_environment => sub { + my $self = shift; + + my $env = super(); + + $env->{'@curried'} = $self->curried_arguments; + + return $env if $self->_slot_access_can_be_inlined; + + my $reader = $self->associated_attribute->get_read_method_ref; + $reader = $reader->body if blessed $reader; + + $env->{'$reader'} = \$reader; + + my $writer = $self->associated_attribute->get_write_method_ref; + $writer = $writer->body if blessed $writer; + + $env->{'$writer'} = \$writer; + + return $env; +}; + +sub _slot_access_can_be_inlined { + my $self = shift; + + return $self->is_inline && $self->_instance_is_inlinable; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array.pm b/lib/Moose/Meta/Method/Accessor/Native/Array.pm new file mode 100644 index 0000000..d585648 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Array; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +sub _inline_check_var_is_valid_index { + my $self = shift; + my ($var) = @_; + + return ( + 'if (!defined(' . $var . ') || ' . $var . ' !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => '.$var.','. + 'method_name => "'.$self->delegate_to_method.'",'. + 'type_of_argument => "integer",'. + 'type => "Int",'. + 'argument_noun => "index"', + ) . ';', + '}', + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm new file mode 100644 index 0000000..e47d940 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm @@ -0,0 +1,27 @@ +package Moose::Meta::Method::Accessor::Native::Array::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer', + 'Moose::Meta::Method::Accessor::Native::Array', + 'Moose::Meta::Method::Accessor::Native::Collection'; + +sub _inline_coerce_new_values { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Collection::_inline_coerce_new_values(@_); +} + +sub _new_members { '@_' } + +sub _copy_old_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{(' . $slot_access . ')} ]'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm new file mode 100644 index 0000000..62af0a5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm @@ -0,0 +1,56 @@ +package Moose::Meta::Method::Accessor::Native::Array::accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::set', + 'Moose::Meta::Method::Accessor::Native::Array::get'; + +sub _inline_process_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_process_arguments(@_); +} + +sub _inline_check_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_check_arguments(@_); +} + +sub _return_value { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Array::get::_return_value(@_); +} + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + # get + 'if (@_ == 1) {', + $self->_inline_check_var_is_valid_index('$_[0]'), + $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_return_value($slot_access), + '}', + # set + 'else {', + $self->_inline_writer_core($inv, $slot_access), + '}', + '}', + ); +} + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 2 } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm new file mode 100644 index 0000000..39913ff --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Array::clear; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { '[]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = [];'; +} + +sub _return_value { '' } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm new file mode 100644 index 0000000..724db7a --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Array::count; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm new file mode 100644 index 0000000..bf47e09 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm @@ -0,0 +1,50 @@ +package Moose::Meta::Method::Accessor::Native::Array::delete; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . '@return = splice @potential, $_[0], 1; ' + . '\@potential; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = splice @{ (' . $slot_access . ') }, $_[0], 1;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$return[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm new file mode 100644 index 0000000..59dcc14 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Array::elements; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '@{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm new file mode 100644 index 0000000..32059f8 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::first; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "first",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '&List::Util::first($_[0], @{ (' . $slot_access . ') })'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm new file mode 100644 index 0000000..da22266 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::first_index; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "first_index",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '&List::MoreUtils::first_index($_[0], @{ (' . $slot_access . ') })'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm new file mode 100644 index 0000000..3e88930 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Array::get; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Array'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->[ $_[0] ]'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm new file mode 100644 index 0000000..c750e5b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm @@ -0,0 +1,41 @@ +package Moose::Meta::Method::Accessor::Native::Array::grep; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "grep",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'grep { $_[0]->() } @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm new file mode 100644 index 0000000..c085223 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm @@ -0,0 +1,58 @@ +package Moose::Meta::Method::Accessor::Native::Array::insert; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 2 } + +sub _maximum_arguments { 2 } + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . 'splice @potential, $_[0], 0, $_[1]; ' + . '\@potential; ' + . '})'; +} + +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + return '@_ = ($_[0], $member_coercion->($_[1]));'; +}; + +sub _new_members { '$_[1]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'splice @{ (' . $slot_access . ') }, $_[0], 0, $_[1];'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->[ $_[0] ]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm new file mode 100644 index 0000000..c57c448 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Array::is_empty; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '@{ (' . $slot_access . ') } ? 0 : 1'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm new file mode 100644 index 0000000..b06ae3b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm @@ -0,0 +1,41 @@ +package Moose::Meta::Method::Accessor::Native::Array::join; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Moose::Util::_STRINGLIKE0($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "join",'. + 'type_of_argument => "string",'. + 'type => "Str",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'join $_[0], @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm new file mode 100644 index 0000000..59c6225 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm @@ -0,0 +1,41 @@ +package Moose::Meta::Method::Accessor::Native::Array::map; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "map",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'map { $_[0]->() } @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm new file mode 100644 index 0000000..e72815e --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm @@ -0,0 +1,65 @@ +package Moose::Meta::Method::Accessor::Native::Array::natatime; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!defined($_[0]) || $_[0] !~ /^\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "natatime",'. + 'type_of_argument => "integer",'. + 'type => "Int",'. + 'argument_noun => "n value"', + ) . ';', + '}', + 'if (@_ == 2 && !Params::Util::_CODELIKE($_[1])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[1],'. + 'method_name => "natatime",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",'. + 'ordinal => "second"', + ) . ';', + '}', + ); +} + +sub _inline_return_value { + my $self = shift; + my ($slot_access) = @_; + + return ( + 'my $iter = List::MoreUtils::natatime($_[0], @{ (' . $slot_access . ') });', + 'if ($_[1]) {', + 'while (my @vals = $iter->()) {', + '$_[1]->(@vals);', + '}', + '}', + 'else {', + 'return $iter;', + '}', + ); +} + +# Not called, but needed to satisfy the Reader role +sub _return_value { } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm new file mode 100644 index 0000000..a9df36f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm @@ -0,0 +1,47 @@ +package Moose::Meta::Method::Accessor::Native::Array::pop; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') } > 1 ' + . '? @{ (' . $slot_access . ') }[0..$#{ (' . $slot_access . ') } - 1] ' + . ': () ]'; +} + +sub _inline_capture_return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'my $old = ' . $slot_access . '->[-1];'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'pop @{ (' . $slot_access . ') };'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$old'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm new file mode 100644 index 0000000..eec4344 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm @@ -0,0 +1,36 @@ +package Moose::Meta::Method::Accessor::Native::Array::push; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') }, @_ ]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'push @{ (' . $slot_access . ') }, @_;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm new file mode 100644 index 0000000..12fd9c4 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::reduce; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "reduce",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'List::Util::reduce { $_[0]->($a, $b) } @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm new file mode 100644 index 0000000..b487303 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm @@ -0,0 +1,64 @@ +package Moose::Meta::Method::Accessor::Native::Array::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 2 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . '$potential[$_[0]] = $_[1]; ' + . '\@potential; ' + . '})'; +} + +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + return '@_ = ($_[0], $member_coercion->($_[1]));'; +}; + +sub _new_members { '$_[1]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . '->[$_[0]] = $_[1];'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->[$_[0]]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm new file mode 100644 index 0000000..f4dd6b4 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm @@ -0,0 +1,26 @@ +package Moose::Meta::Method::Accessor::Native::Array::shallow_clone; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 0 } + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') } ]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm new file mode 100644 index 0000000..f0c3057 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm @@ -0,0 +1,47 @@ +package Moose::Meta::Method::Accessor::Native::Array::shift; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') } > 1 ' + . '? @{ (' . $slot_access . ') }[1..$#{ (' . $slot_access . ') }] ' + . ': () ]'; +} + +sub _inline_capture_return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'my $old = ' . $slot_access . '->[0];'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'shift @{ (' . $slot_access . ') };'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$old'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm new file mode 100644 index 0000000..9e7a93e --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Array::shuffle; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'List::Util::shuffle @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm new file mode 100644 index 0000000..a1b15a1 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm @@ -0,0 +1,44 @@ +package Moose::Meta::Method::Accessor::Native::Array::sort; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (@_ && !Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "sort",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return + 'wantarray ? ( ' . + '$_[0] ' + . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } ' + . ': sort @{ (' . $slot_access . ') }' + . ' ) : @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm new file mode 100644 index 0000000..cfdb2c1 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm @@ -0,0 +1,45 @@ +package Moose::Meta::Method::Accessor::Native::Array::sort_in_place; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (@_ && !Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "sort_in_place",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ $_[0] ' + . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } ' + . ': sort @{ (' . $slot_access . ') } ]'; +} + +sub _return_value { '' } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm new file mode 100644 index 0000000..8bbc6df --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm @@ -0,0 +1,72 @@ +package Moose::Meta::Method::Accessor::Native::Array::splice; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 1 } + +sub _adds_members { 1 } + +sub _inline_process_arguments { + return ( + 'my $idx = shift;', + 'my $len = @_ ? shift : undef;', + ); +} + +sub _inline_check_arguments { + my $self = shift; + + return ( + $self->_inline_check_var_is_valid_index('$idx'), + 'if (defined($len) && $len !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $len,'. + 'method_name => "splice",'. + 'type_of_argument => "integer",'. + 'type => "Int",'. + 'argument_noun => "length argument"', + ) . ';', + '}', + ); +} + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . '@return = defined $len ' + . '? (splice @potential, $idx, $len, @_) ' + . ': (splice @potential, $idx); ' + . '\@potential;' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return ( + '@return = defined $len', + '? (splice @{ (' . $slot_access . ') }, $idx, $len, @_)', + ': (splice @{ (' . $slot_access . ') }, $idx);', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'wantarray ? @return : $return[-1]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm new file mode 100644 index 0000000..535b802 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Array::uniq; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'List::MoreUtils::uniq @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm new file mode 100644 index 0000000..4111671 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm @@ -0,0 +1,36 @@ +package Moose::Meta::Method::Accessor::Native::Array::unshift; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @_, @{ (' . $slot_access . ') } ]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'unshift @{ (' . $slot_access . ') }, @_;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm new file mode 100644 index 0000000..60eb646 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Bool::not; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '!' . $slot_access; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm new file mode 100644 index 0000000..725da20 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Bool::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { 1 } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm new file mode 100644 index 0000000..663b1a2 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm @@ -0,0 +1,29 @@ +package Moose::Meta::Method::Accessor::Native::Bool::toggle; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' ? 0 : 1'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = ' . $slot_access . ' ? 0 : 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm new file mode 100644 index 0000000..6c5c62b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Bool::unset; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { 0 } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = 0;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm b/lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm new file mode 100644 index 0000000..c74604f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Code::execute; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->(@_)'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm b/lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm new file mode 100644 index 0000000..b3d40b9 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Code::execute_method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->($self, @_)'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm new file mode 100644 index 0000000..67331d5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm @@ -0,0 +1,167 @@ +package Moose::Meta::Method::Accessor::Native::Collection; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +requires qw( _adds_members ); + +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + return ( + '(' . $self->_new_members . ') = map { $member_coercion->($_) }', + $self->_new_members . ';', + ); +} + +sub _tc_member_type_can_coerce { + my $self = shift; + + my $member_tc = $self->_tc_member_type; + + return $member_tc && $member_tc->has_coercion; +} + +sub _tc_member_type { + my $self = shift; + + my $tc = $self->associated_attribute->type_constraint; + while ($tc) { + return $tc->type_parameter + if $tc->can('type_parameter'); + $tc = $tc->parent; + } + + return; +} + +sub _writer_value_needs_copy { + my $self = shift; + + return $self->_constraint_must_be_checked + && !$self->_check_new_members_only; +} + +sub _inline_tc_code { + my $self = shift; + my ($value, $tc, $coercion, $message, $is_lazy) = @_; + + return unless $self->_constraint_must_be_checked; + + if ($self->_check_new_members_only) { + return unless $self->_adds_members; + + return $self->_inline_check_member_constraint($self->_new_members); + } + else { + return ( + $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy), + $self->_inline_check_constraint($value, $tc, $message, $is_lazy), + ); + } +} + +sub _check_new_members_only { + my $self = shift; + + my $attr = $self->associated_attribute; + + my $tc = $attr->type_constraint; + + # If we have a coercion, we could come up with an entirely new value after + # coercing, so we need to check everything, + return 0 if $attr->should_coerce && $tc->has_coercion; + + # If the parent is our root type (ArrayRef, HashRef, etc), that means we + # can just check the new members of the collection, because we know that + # we will always be generating an appropriate collection type. + # + # However, if this type has its own constraint (it's Parameteriz_able_, + # not Paramet_erized_), we don't know what is being checked by the + # constraint, so we need to check the whole value, not just the members. + return 1 + if $self->_is_root_type( $tc->parent ) + && ( $tc->isa('Moose::Meta::TypeConstraint::Parameterized') + || $tc->isa('Specio::Constraint::Parameterized') ); + + return 0; +} + +sub _inline_check_member_constraint { + my $self = shift; + my ($new_value) = @_; + + my $attr_name = $self->associated_attribute->name; + + my $check + = $self->_tc_member_type->can_be_inlined + ? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')' + : ' !$member_tc->($new_val) '; + + return ( + 'for my $new_val (' . $new_value . ') {', + "if ($check) {", + 'my $msg = do { local $_ = $new_val; $member_message->($new_val) };'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + "attribute_name => '".$attr_name."',". + 'type_constraint_message => $msg,'. + 'class_name => $class_name,'. + 'value => $new_val,'. + 'new_member => 1', + ) . ';', + '}', + '}', + ); +} + +sub _inline_get_old_value_for_trigger { + my $self = shift; + my ($instance, $old) = @_; + + my $attr = $self->associated_attribute; + return unless $attr->has_trigger; + + return ( + 'my ' . $old . ' = ' . $self->_has_value($instance), + '? ' . $self->_copy_old_value($self->_get_value($instance)), + ': ();', + ); +} + +around _eval_environment => sub { + my $orig = shift; + my $self = shift; + + my $env = $self->$orig(@_); + + my $member_tc = $self->_tc_member_type; + + return $env unless $member_tc; + + $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint ); + $env->{'$member_coercion'} = \( + $member_tc->coercion->_compiled_type_coercion + ) if $member_tc->has_coercion; + $env->{'$member_message'} = \( + $member_tc->has_message + ? $member_tc->message + : $member_tc->_default_message + ); + + my $tc_env = $member_tc->inline_environment(); + + $env = { %{$env}, %{$tc_env} }; + + return $env; +}; + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm new file mode 100644 index 0000000..55ab4a7 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Counter::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _constraint_must_be_checked { + my $self = shift; + + my $attr = $self->associated_attribute; + + return $attr->has_type_constraint + && ($attr->type_constraint->name =~ /^(?:Num|Int)$/ + || ($attr->should_coerce && $attr->type_constraint->has_coercion) + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm new file mode 100644 index 0000000..3e61d59 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm @@ -0,0 +1,30 @@ +package Moose::Meta::Method::Accessor::Native::Counter::dec; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 0 } +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' - (defined $_[0] ? $_[0] : 1)'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' -= defined $_[0] ? $_[0] : 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm new file mode 100644 index 0000000..1efeab8 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm @@ -0,0 +1,30 @@ +package Moose::Meta::Method::Accessor::Native::Counter::inc; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 0 } +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' + (defined $_[0] ? $_[0] : 1)'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' += defined $_[0] ? $_[0] : 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm new file mode 100644 index 0000000..b62ac7b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm @@ -0,0 +1,36 @@ +package Moose::Meta::Method::Accessor::Native::Counter::reset; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + my $attr = $self->associated_attribute; + + return '(do { ' + . join(' ', $attr->_inline_generate_default( + '$self', '$default_for_reset' + )) . ' ' + . '$default_for_reset; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = ' . $self->_potential_value . ';'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm new file mode 100644 index 0000000..671984c --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm @@ -0,0 +1,25 @@ +package Moose::Meta::Method::Accessor::Native::Counter::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 1 } + +sub _potential_value { '$_[0]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash.pm new file mode 100644 index 0000000..721c5f5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Hash; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +sub _inline_check_var_is_valid_key { + my $self = shift; + my ($var) = @_; + + return ( + 'if (!defined(' . $var . ')) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => '.$var.','. + 'method_name => "'.$self->delegate_to_method.'",'. + 'type_of_argument => "defined value",'. + 'type => "Defined",'. + 'argument_noun => "key"', + ) . ';', + '}', + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm new file mode 100644 index 0000000..ccc3e1f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Hash::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer', + 'Moose::Meta::Method::Accessor::Native::Hash', + 'Moose::Meta::Method::Accessor::Native::Collection'; + +sub _inline_coerce_new_values { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Collection::_inline_coerce_new_values(@_); +} + +sub _new_values { '@values' } + +sub _copy_old_value { + my $self = shift; + my ($slot_access) = @_; + + return '{ %{ (' . $slot_access . ') } }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm new file mode 100644 index 0000000..f4f978e --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm @@ -0,0 +1,61 @@ +package Moose::Meta::Method::Accessor::Native::Hash::accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::set', + 'Moose::Meta::Method::Accessor::Native::Hash::get'; + +sub _inline_process_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_process_arguments(@_); +} + +sub _inline_check_argument_count { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_check_argument_count(@_); +} + +sub _inline_check_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_check_arguments(@_); +} + +sub _return_value { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_return_value(@_); +} + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + # get + 'if (@_ == 1) {', + $self->_inline_check_var_is_valid_key('$_[0]'), + $slot_access . '->{$_[0]}', + '}', + # set + 'else {', + $self->_inline_writer_core($inv, $slot_access), + '}', + '}', + ); +} + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 2 } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm new file mode 100644 index 0000000..751a443 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Hash::clear; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { '{}' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = {};'; +} + +sub _return_value { '' } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm new file mode 100644 index 0000000..aca9116 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::count; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm new file mode 100644 index 0000000..0062918 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Hash::defined; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Hash'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_key('$_[0]'); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'defined ' . $slot_access . '->{ $_[0] }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm new file mode 100644 index 0000000..1a6d706 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm @@ -0,0 +1,40 @@ +package Moose::Meta::Method::Accessor::Native::Hash::delete; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my %potential = %{ (' . $slot_access . ') }; ' + . '@return = delete @potential{@_}; ' + . '\%potential; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = delete @{ (' . $slot_access . ') }{@_};'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'wantarray ? @return : $return[-1]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm new file mode 100644 index 0000000..d1ba09d --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm @@ -0,0 +1,23 @@ +package Moose::Meta::Method::Accessor::Native::Hash::elements; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'map { $_, ' . $slot_access . '->{$_} } ' + . 'keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm new file mode 100644 index 0000000..7ab09cc --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Hash::exists; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Hash'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_key('$_[0]'); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = shift; + + return 'exists ' . $slot_access . '->{ $_[0] }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm new file mode 100644 index 0000000..a91c8f8 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm @@ -0,0 +1,35 @@ +package Moose::Meta::Method::Accessor::Native::Hash::get; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Hash'; + +sub _minimum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'for (@_) {', + $self->_inline_check_var_is_valid_key('$_'), + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '@_ > 1 ' + . '? @{ (' . $slot_access . ') }{@_} ' + . ': ' . $slot_access . '->{$_[0]}'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm new file mode 100644 index 0000000..7948927 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::is_empty; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar keys %{ (' . $slot_access . ') } ? 0 : 1'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm new file mode 100644 index 0000000..439be94 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::keys; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm new file mode 100644 index 0000000..4bbb325 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm @@ -0,0 +1,23 @@ +package Moose::Meta::Method::Accessor::Native::Hash::kv; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'map { [ $_, ' . $slot_access . '->{$_} ] } ' + . 'keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm new file mode 100644 index 0000000..7d7a1fa --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm @@ -0,0 +1,103 @@ +package Moose::Meta::Method::Accessor::Native::Hash::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; + +sub _minimum_arguments { 2 } + +sub _maximum_arguments { undef } + +around _inline_check_argument_count => sub { + my $orig = shift; + my $self = shift; + + return ( + $self->$orig(@_), + 'if (@_ % 2) {', + $self->_inline_throw_exception( MustPassEvenNumberOfArguments => + "method_name => '".$self->delegate_to_method."',". + 'args => \@_', + ) . ';', + '}', + ); +}; + +sub _inline_process_arguments { + my $self = shift; + + return ( + 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;', + 'my @values_idx = grep { $_ % 2 } 0..$#_;', + ); +} + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'for (@keys_idx) {', + 'if (!defined($_[$_])) {', + $self->_inline_throw_exception( UndefinedHashKeysPassedToMethod => + 'hash_keys => \@keys_idx,'. + "method_name => '".$self->delegate_to_method."'", + ) . ';', + '}', + '}', + ); +} + +sub _adds_members { 1 } + +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + # Is there a simpler way to do this? + return ( + 'my $iter = List::MoreUtils::natatime(2, @_);', + '@_ = ();', + 'while (my ($key, $val) = $iter->()) {', + 'push @_, $key, $member_coercion->($val);', + '}', + ); +}; + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '{ %{ (' . $slot_access . ') }, @_ }'; +} + +sub _new_members { '@_[ @values_idx ]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'wantarray ' + . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } ' + . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm new file mode 100644 index 0000000..62b09cb --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm @@ -0,0 +1,26 @@ +package Moose::Meta::Method::Accessor::Native::Hash::shallow_clone; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 0 } + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '{ %{ (' . $slot_access . ') } }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm new file mode 100644 index 0000000..750ce76 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::values; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'values %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm new file mode 100644 index 0000000..987a89f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm @@ -0,0 +1,29 @@ +package Moose::Meta::Method::Accessor::Native::Number::abs; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return 'abs(' . $slot_access . ')'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = abs(' . $slot_access . ');'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/add.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/add.pm new file mode 100644 index 0000000..a7bd95c --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/add.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::add; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' + $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' += $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/div.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/div.pm new file mode 100644 index 0000000..e2037a2 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/div.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::div; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' / $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' /= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm new file mode 100644 index 0000000..80a3c2a --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::mod; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' % $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' %= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm new file mode 100644 index 0000000..6b019a6 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::mul; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' * $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' *= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/set.pm new file mode 100644 index 0000000..2aa9c40 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/set.pm @@ -0,0 +1,25 @@ +package Moose::Meta::Method::Accessor::Native::Number::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 1 } + +sub _potential_value { '$_[0]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm new file mode 100644 index 0000000..c2fa157 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::sub; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' - $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' -= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm new file mode 100644 index 0000000..df885e5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm @@ -0,0 +1,47 @@ +package Moose::Meta::Method::Accessor::Native::Reader; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native'; + +requires '_return_value'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_reader_core($inv, $slot_access, @_), + '}', + ); +} + +sub _inline_reader_core { + my $self = shift; + my ($inv, $slot_access, @extra) = @_; + + return ( + $self->_inline_check_argument_count, + $self->_inline_process_arguments($inv, $slot_access), + $self->_inline_check_arguments, + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + $self->_inline_return_value($slot_access), + ); +} + +sub _inline_process_arguments { return } + +sub _inline_check_arguments { return } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/append.pm b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm new file mode 100644 index 0000000..e941e5a --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::String::append; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '( ' . $slot_access . ' . $_[0] )'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' .= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm new file mode 100644 index 0000000..49e2215 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm @@ -0,0 +1,40 @@ +package Moose::Meta::Method::Accessor::Native::String::chomp; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . '@return = chomp $val; ' + . '$val ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = chomp ' . $slot_access . ';'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$return[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm new file mode 100644 index 0000000..c15fd0f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm @@ -0,0 +1,40 @@ +package Moose::Meta::Method::Accessor::Native::String::chop; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . '@return = chop $val; ' + . '$val; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = chop ' . $slot_access . ';'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$return[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm new file mode 100644 index 0000000..7aec2c5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::String::clear; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { '""' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = "";'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm new file mode 100644 index 0000000..3ee5605 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm @@ -0,0 +1,33 @@ +package Moose::Meta::Method::Accessor::Native::String::inc; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . '$val++; ' + . '$val; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . '++;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/length.pm b/lib/Moose/Meta/Method/Accessor/Native/String/length.pm new file mode 100644 index 0000000..bf40b40 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/length.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::String::length; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'length ' . $slot_access; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/match.pm b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm new file mode 100644 index 0000000..ae85a96 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::String::match; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'type => "Str|RegexpRef",'. + 'type_of_argument => "string or regexp reference",'. + 'method_name => "match"', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' =~ $_[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm new file mode 100644 index 0000000..87a0695 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::String::prepend; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '$_[0] . ' . $slot_access; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = $_[0] . ' . $slot_access . ';'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm new file mode 100644 index 0000000..6e33609 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm @@ -0,0 +1,69 @@ +package Moose::Meta::Method::Accessor::Native::String::replace; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "replace",'. + 'ordinal => "first",'. + 'type_of_argument => "string or regexp reference",'. + 'type => "Str|RegexpRef"', + ) . ';', + '}', + 'if (!Moose::Util::_STRINGLIKE0($_[1]) && !Params::Util::_CODELIKE($_[1])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[1],'. + 'method_name => "replace",'. + 'ordinal => "second",'. + 'type_of_argument => "string or code reference",'. + 'type => "Str|CodeRef"', + ) . ';', + '}', + ); +} + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . 'ref $_[1] ' + . '? $val =~ s/$_[0]/$_[1]->()/e ' + . ': $val =~ s/$_[0]/$_[1]/; ' + . '$val; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return ( + 'ref $_[1]', + '? ' . $slot_access . ' =~ s/$_[0]/$_[1]->()/e', + ': ' . $slot_access . ' =~ s/$_[0]/$_[1]/;', + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm new file mode 100644 index 0000000..df82e23 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm @@ -0,0 +1,123 @@ +package Moose::Meta::Method::Accessor::Native::String::substr; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + 'if (@_ == 1 || @_ == 2) {', + $self->_inline_reader_core($inv, $slot_access), + '}', + 'elsif (@_ == 3) {', + $self->_inline_writer_core($inv, $slot_access), + '}', + 'else {', + $self->_inline_check_argument_count, + '}', + '}', + ); +} + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 3 } + +sub _inline_process_arguments { + my $self = shift; + my ($inv, $slot_access) = @_; + + return ( + 'my $offset = shift;', + 'my $length = @_ ? shift : length ' . $slot_access . ';', + 'my $replacement = shift;', + ); +} + +sub _inline_check_arguments { + my $self = shift; + my ($for_writer) = @_; + + my @code = ( + 'if ($offset !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $offset,'. + 'ordinal => "first",'. + 'type_of_argument => "integer",'. + 'method_name => "substr",'. + 'type => "Int"', + ) . ';', + '}', + 'if ($length !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $length,'. + 'ordinal => "second",'. + 'type_of_argument => "integer",'. + 'method_name => "substr",'. + 'type => "Int"', + ) . ';', + '}', + ); + + if ($for_writer) { + push @code, ( + 'if (!Moose::Util::_STRINGLIKE0($replacement)) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $replacement,'. + 'ordinal => "third",'. + 'type_of_argument => "string",'. + 'method_name => "substr",'. + 'type => "Str"', + ) . ';', + '}', + ); + } + + return @code; +} + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $potential = ' . $slot_access . '; ' + . '@return = substr $potential, $offset, $length, $replacement; ' + . '$potential; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = substr ' . $slot_access . ', ' + . '$offset, $length, $replacement;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access, $for_writer) = @_; + + return '$return[0]' if $for_writer; + + return 'substr ' . $slot_access . ', $offset, $length'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm new file mode 100644 index 0000000..b25e063 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm @@ -0,0 +1,174 @@ +package Moose::Meta::Method::Accessor::Native::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util 1.33 qw( any ); +use Moose::Util; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native'; + +requires '_potential_value'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_writer_core($inv, $slot_access), + '}', + ); +} + +sub _inline_writer_core { + my $self = shift; + my ($inv, $slot_access) = @_; + + my $potential = $self->_potential_value($slot_access); + my $old = '@old'; + + my @code; + push @code, ( + $self->_inline_check_argument_count, + $self->_inline_process_arguments($inv, $slot_access), + $self->_inline_check_arguments('for writer'), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + ); + + if ($self->_return_value($slot_access)) { + # some writers will save the return value in this variable when they + # generate the potential value. + push @code, 'my @return;' + } + + push @code, ( + $self->_inline_coerce_new_values, + $self->_inline_copy_native_value(\$potential), + $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_message'), + $self->_inline_get_old_value_for_trigger($inv, $old), + $self->_inline_capture_return_value($slot_access), + $self->_inline_set_new_value($inv, $potential, $slot_access), + $self->_inline_trigger($inv, $slot_access, $old), + $self->_inline_return_value($slot_access, 'for writer'), + ); + + return @code; +} + +sub _inline_process_arguments { return } + +sub _inline_check_arguments { return } + +sub _inline_coerce_new_values { return } + +sub _writer_value_needs_copy { + my $self = shift; + + return $self->_constraint_must_be_checked; +} + +sub _constraint_must_be_checked { + my $self = shift; + + my $attr = $self->associated_attribute; + + return $attr->has_type_constraint + && ( !$self->_is_root_type( $attr->type_constraint ) + || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); +} + +sub _is_root_type { + my $self = shift; + my $type = shift; + + if ( blessed($type) + && $type->can('does') + && $type->does('Specio::Constraint::Role::Interface') ) + { + require Specio::Library::Builtins; + return + any { $type->is_same_type_as( Specio::Library::Builtins::t($_) ) } + @{ $self->root_types }; + } + else { + my $name = $type->name; + return any { $name eq $_ } @{ $self->root_types }; + } +} + +sub _inline_copy_native_value { + my $self = shift; + my ($potential_ref) = @_; + + return unless $self->_writer_value_needs_copy; + + my $code = 'my $potential = ' . ${$potential_ref} . ';'; + + ${$potential_ref} = '$potential'; + + return $code; +} + +around _inline_tc_code => sub { + my $orig = shift; + my $self = shift; + my ($value, $tc, $coercion, $message, $for_lazy) = @_; + + return unless $for_lazy || $self->_constraint_must_be_checked; + + return $self->$orig(@_); +}; + +around _inline_check_constraint => sub { + my $orig = shift; + my $self = shift; + my ($value, $tc, $message, $for_lazy) = @_; + + return unless $for_lazy || $self->_constraint_must_be_checked; + + return $self->$orig(@_); +}; + +sub _inline_capture_return_value { return } + +sub _inline_set_new_value { + my $self = shift; + + return $self->_inline_store_value(@_) + if $self->_writer_value_needs_copy + || !$self->_slot_access_can_be_inlined + || !$self->_get_is_lvalue; + + return $self->_inline_optimized_set_new_value(@_); +} + +sub _get_is_lvalue { + my $self = shift; + + return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + + return $self->_inline_store_value(@_); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Augmented.pm b/lib/Moose/Meta/Method/Augmented.pm new file mode 100644 index 0000000..56a07d1 --- /dev/null +++ b/lib/Moose/Meta/Method/Augmented.pm @@ -0,0 +1,175 @@ +package Moose::Meta::Method::Augmented; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method'; + +use Moose::Util 'throw_exception'; + +sub new { + my ( $class, %args ) = @_; + + # the package can be overridden by roles + # it is really more like body's compilation stash + # this is where we need to override the definition of super() so that the + # body of the code can call the right overridden version + my $name = $args{name}; + my $meta = $args{class}; + + my $super = $meta->find_next_method_by_name($name); + + (defined $super) + || throw_exception( CannotAugmentNoSuperMethod => params => \%args, + class => $class, + method_name => $name + ); + + my $_super_package = $super->package_name; + # BUT!,... if this is an overridden method .... + if ($super->isa('Moose::Meta::Method::Overridden')) { + # we need to be sure that we actually + # find the next method, which is not + # an 'override' method, the reason is + # that an 'override' method will not + # be the one calling inner() + my $real_super = $meta->_find_next_method_by_name_which_is_not_overridden($name); + $_super_package = $real_super->package_name; + } + + my $super_body = $super->body; + + my $method = $args{method}; + + my $body = sub { + local $Moose::INNER_ARGS{$_super_package} = [ @_ ]; + local $Moose::INNER_BODY{$_super_package} = $method; + $super_body->(@_); + }; + + # FIXME store additional attrs + $class->wrap( + $body, + package_name => $meta->name, + name => $name + ); +} + +1; + +# ABSTRACT: A Moose Method metaclass for augmented methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Augmented - A Moose Method metaclass for augmented methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements method augmentation logic for the L<Moose> +C<augment> keyword. + +The augmentation subroutine reference will be invoked explicitly using +the C<inner> keyword from the parent class's method definition. + +=head1 INHERITANCE + +C<Moose::Meta::Method::Augmented> is a subclass of L<Moose::Meta::Method>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Augmented->new(%options) >> + +This constructs a new object. It accepts the following options: + +=over 8 + +=item * class + +The metaclass object for the class in which the augmentation is being +declared. This option is required. + +=item * name + +The name of the method which we are augmenting. This method must exist +in one of the class's superclasses. This option is required. + +=item * method + +The subroutine reference which implements the augmentation. This +option is required. + +=back + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm new file mode 100644 index 0000000..c6aaebb --- /dev/null +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -0,0 +1,145 @@ +package Moose::Meta::Method::Constructor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'weaken'; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Constructor'; + +use Moose::Util 'throw_exception'; + +sub new { + my $class = shift; + my %options = @_; + + my $meta = $options{metaclass}; + + (ref $options{options} eq 'HASH') + || throw_exception( MustPassAHashOfOptions => params => \%options, + class => $class + ); + + ($options{package_name} && $options{name}) + || throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = bless { + 'body' => undef, + 'package_name' => $options{package_name}, + 'name' => $options{name}, + 'options' => $options{options}, + 'associated_metaclass' => $meta, + 'definition_context' => $options{definition_context}, + '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object', + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'associated_metaclass'}); + + $self->_initialize_body; + + return $self; +} + +## method + +sub _initialize_body { + my $self = shift; + $self->{'body'} = $self->_generate_constructor_method_inline; +} + +1; + +# ABSTRACT: Method Meta Object for constructors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Constructor - Method Meta Object for constructors + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Constructor> that +provides additional Moose-specific functionality + +To understand this class, you should read the the +L<Class::MOP::Method::Constructor> documentation as well. + +=head1 INHERITANCE + +C<Moose::Meta::Method::Constructor> is a subclass of +L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm new file mode 100644 index 0000000..752bd27 --- /dev/null +++ b/lib/Moose/Meta/Method/Delegation.pm @@ -0,0 +1,258 @@ +package Moose::Meta::Method::Delegation; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Generated'; + +use Moose::Util 'throw_exception'; + +sub new { + my $class = shift; + my %options = @_; + + ( exists $options{attribute} ) + || throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options, + class => $class + ); + + ( blessed( $options{attribute} ) + && $options{attribute}->isa('Moose::Meta::Attribute') ) + || throw_exception( MustSupplyAMooseMetaAttributeInstance => params => \%options, + class => $class + ); + + ( $options{package_name} && $options{name} ) + || throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} ) + || ( 'CODE' eq ref $options{delegate_to_method} ) ) + || throw_exception( MustSupplyADelegateToMethod => params => \%options, + class => $class + ); + + exists $options{curried_arguments} + || ( $options{curried_arguments} = [] ); + + ( $options{curried_arguments} && + ( 'ARRAY' eq ref $options{curried_arguments} ) ) + || throw_exception( MustSupplyArrayRefAsCurriedArguments => params => \%options, + class_name => $class + ); + + my $self = $class->_new( \%options ); + + weaken( $self->{'attribute'} ); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless $options, $class; +} + +sub curried_arguments { (shift)->{'curried_arguments'} } + +sub associated_attribute { (shift)->{'attribute'} } + +sub delegate_to_method { (shift)->{'delegate_to_method'} } + +sub _initialize_body { + my $self = shift; + + my $method_to_call = $self->delegate_to_method; + return $self->{body} = $method_to_call + if ref $method_to_call; + + my $accessor = $self->_get_delegate_accessor; + + my $handle_name = $self->name; + + # NOTE: we used to do a goto here, but the goto didn't handle + # failure correctly (it just returned nothing), so I took that + # out. However, the more I thought about it, the less I liked it + # doing the goto, and I preferred the act of delegation being + # actually represented in the stack trace. - SL + # not inlining this, since it won't really speed things up at + # all... the only thing that would end up different would be + # interpolating in $method_to_call, and a bunch of things in the + # error handling that mostly never gets called - doy + $self->{body} = sub { + my $instance = shift; + my $proxy = $instance->$accessor(); + + if( !defined $proxy ) { + throw_exception( AttributeValueIsNotDefined => method => $self, + instance => $instance, + attribute => $self->associated_attribute, + ); + } + elsif( ref($proxy) && !blessed($proxy) ) { + throw_exception( AttributeValueIsNotAnObject => method => $self, + instance => $instance, + attribute => $self->associated_attribute, + given_value => $proxy + ); + } + + unshift @_, @{ $self->curried_arguments }; + $proxy->$method_to_call(@_); + }; +} + +sub _get_delegate_accessor { + my $self = shift; + my $attr = $self->associated_attribute; + + # NOTE: + # always use a named method when + # possible, if you use the method + # ref and there are modifiers on + # the accessors then it will not + # pick up the modifiers too. Only + # the named method will assure that + # we also have any modifiers run. + # - SL + my $accessor = $attr->has_read_method + ? $attr->get_read_method + : $attr->get_read_method_ref; + + $accessor = $accessor->body if Scalar::Util::blessed $accessor; + + return $accessor; +} + +1; + +# ABSTRACT: A Moose Method metaclass for delegation methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a subclass of L<Moose::Meta::Method> for delegation +methods. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Delegation->new(%options) >> + +This creates the delegation methods based on the provided C<%options>. + +=over 4 + +=item I<attribute> + +This must be an instance of C<Moose::Meta::Attribute> which this +accessor is being generated for. This options is B<required>. + +=item I<delegate_to_method> + +The method in the associated attribute's value to which we +delegate. This can be either a method name or a code reference. + +=item I<curried_arguments> + +An array reference of arguments that will be prepended to the argument list for +any call to the delegating method. + +=back + +=item B<< $metamethod->associated_attribute >> + +Returns the attribute associated with this method. + +=item B<< $metamethod->curried_arguments >> + +Return any curried arguments that will be passed to the delegated method. + +=item B<< $metamethod->delegate_to_method >> + +Returns the method to which this method delegates, as passed to the +constructor. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm new file mode 100644 index 0000000..cd37245 --- /dev/null +++ b/lib/Moose/Meta/Method/Destructor.pm @@ -0,0 +1,255 @@ +package Moose::Meta::Method::Destructor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Devel::GlobalDestruction (); +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Inlined'; + +use Moose::Util 'throw_exception'; + +sub new { + my $class = shift; + my %options = @_; + + (ref $options{options} eq 'HASH') + || throw_exception( MustPassAHashOfOptions => params => \%options, + class => $class + ); + + ($options{package_name} && $options{name}) + || throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = bless { + # from our superclass + 'body' => undef, + 'package_name' => $options{package_name}, + 'name' => $options{name}, + # ... + 'options' => $options{options}, + 'definition_context' => $options{definition_context}, + 'associated_metaclass' => $options{metaclass}, + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'associated_metaclass'}); + + $self->_initialize_body; + + return $self; +} + +## accessors + +sub options { (shift)->{'options'} } + +## method + +sub is_needed { + my $self = shift; + my $metaclass = shift; + + ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') ) + || throw_exception( MethodExpectedAMetaclassObject => metaclass => $metaclass, + class => $self + ); + + return $metaclass->find_method_by_name("DEMOLISHALL"); +} + +sub _initialize_body { + my $self = shift; + # TODO: + # the %options should also include a both + # a call 'initializer' and call 'SUPER::' + # options, which should cover approx 90% + # of the possible use cases (even if it + # requires some adaption on the part of + # the author, after all, nothing is free) + + my $class = $self->associated_metaclass->name; + my @source = ( + 'sub {', + 'my $self = shift;', + 'return ' . $self->_generate_fallback_destructor('$self'), + 'if Scalar::Util::blessed($self) ne \'' . $class . '\';', + $self->_generate_DEMOLISHALL('$self'), + 'return;', + '}', + ); + warn join("\n", @source) if $self->options->{debug}; + + my $code = try { + $self->_compile_code(source => \@source); + } + catch { + my $source = join("\n", @source); + throw_exception( CouldNotEvalDestructor => method_destructor_object => $self, + source => $source, + error => $_ + ); + }; + + $self->{'body'} = $code; +} + +sub _generate_fallback_destructor { + my $self = shift; + my ($inv) = @_; + + return $inv . '->Moose::Object::DESTROY(@_)'; +} + +sub _generate_DEMOLISHALL { + my $self = shift; + my ($inv) = @_; + + my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH'); + return unless @methods; + + return ( + 'local $?;', + 'my $igd = Devel::GlobalDestruction::in_global_destruction;', + 'Try::Tiny::try {', + (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods), + '}', + 'Try::Tiny::catch {', + 'die $_;', + '};', + ); +} + + +1; + +# ABSTRACT: Method Meta Object for destructors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Destructor - Method Meta Object for destructors + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Inlined> that +provides Moose-specific functionality for inlining destructors. + +To understand this class, you should read the +L<Class::MOP::Method::Inlined> documentation as well. + +=head1 INHERITANCE + +C<Moose::Meta::Method::Destructor> is a subclass of +L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Inlined>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Destructor->new(%options) >> + +This constructs a new object. It accepts the following options: + +=over 8 + +=item * package_name + +The package for the class in which the destructor is being +inlined. This option is required. + +=item * name + +The name of the destructor method. This option is required. + +=item * metaclass + +The metaclass for the class this destructor belongs to. This is +optional, as it can be set later by calling C<< +$metamethod->attach_to_class >>. + +=back + +=item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >> + +Given a L<Moose::Meta::Class> object, this method returns a boolean +indicating whether the class needs a destructor. If the class or any +of its parents defines a C<DEMOLISH> method, it needs a destructor. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Meta.pm b/lib/Moose/Meta/Method/Meta.pm new file mode 100644 index 0000000..7796683 --- /dev/null +++ b/lib/Moose/Meta/Method/Meta.pm @@ -0,0 +1,112 @@ +package Moose::Meta::Method::Meta; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Meta'; + +sub _is_caller_mop_internal { + my $self = shift; + my ($caller) = @_; + return 1 if $caller =~ /^Moose(?:::|$)/; + return $self->SUPER::_is_caller_mop_internal($caller); +} + +# XXX: ugh multiple inheritance +sub wrap { + my $class = shift; + return $class->Class::MOP::Method::Meta::wrap(@_); +} + +sub _make_compatible_with { + my $self = shift; + return $self->Class::MOP::Method::Meta::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: A Moose Method metaclass for C<meta> methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Meta - A Moose Method metaclass for C<meta> methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Meta> that +provides additional Moose-specific functionality, all of which is +private. + +To understand this class, you should read the the +L<Class::MOP::Method::Meta> documentation. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Overridden.pm b/lib/Moose/Meta/Method/Overridden.pm new file mode 100644 index 0000000..4c9aee7 --- /dev/null +++ b/lib/Moose/Meta/Method/Overridden.pm @@ -0,0 +1,164 @@ +package Moose::Meta::Method::Overridden; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method'; + +use Moose::Util 'throw_exception'; + +sub new { + my ( $class, %args ) = @_; + + # the package can be overridden by roles + # it is really more like body's compilation stash + # this is where we need to override the definition of super() so that the + # body of the code can call the right overridden version + my $super_package = $args{package} || $args{class}->name; + + my $name = $args{name}; + + my $super = $args{class}->find_next_method_by_name($name); + + (defined $super) + || throw_exception( CannotOverrideNoSuperMethod => class => $class, + params => \%args, + method_name => $name + ); + + my $super_body = $super->body; + + my $method = $args{method}; + + my $body = sub { + local $Moose::SUPER_PACKAGE = $super_package; + local @Moose::SUPER_ARGS = @_; + local $Moose::SUPER_BODY = $super_body; + return $method->(@_); + }; + + # FIXME do we need this make sure this works for next::method? + # subname "${super_package}::${name}", $method; + + # FIXME store additional attrs + $class->wrap( + $body, + package_name => $args{class}->name, + name => $name + ); +} + +1; + +# ABSTRACT: A Moose Method metaclass for overridden methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Overridden - A Moose Method metaclass for overridden methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements method overriding logic for the L<Moose> +C<override> keyword. + +The overriding subroutine's parent will be invoked explicitly using +the C<super> keyword from the parent class's method definition. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Overridden->new(%options) >> + +This constructs a new object. It accepts the following options: + +=over 8 + +=item * class + +The metaclass object for the class in which the override is being +declared. This option is required. + +=item * name + +The name of the method which we are overriding. This method must exist +in one of the class's superclasses. This option is required. + +=item * method + +The subroutine reference which implements the overriding. This option +is required. + +=back + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Mixin/AttributeCore.pm b/lib/Moose/Meta/Mixin/AttributeCore.pm new file mode 100644 index 0000000..8503d8f --- /dev/null +++ b/lib/Moose/Meta/Mixin/AttributeCore.pm @@ -0,0 +1,184 @@ +package Moose::Meta::Mixin::AttributeCore; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Class::MOP::Mixin::AttributeCore'; + +__PACKAGE__->meta->add_attribute( + 'isa' => ( + reader => '_isa_metadata', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'does' => ( + reader => '_does_metadata', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'is' => ( + reader => '_is_metadata', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'required' => ( + reader => 'is_required', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'lazy' => ( + reader => 'is_lazy', Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'lazy_build' => ( + reader => 'is_lazy_build', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'coerce' => ( + reader => 'should_coerce', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'weak_ref' => ( + reader => 'is_weak_ref', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'auto_deref' => ( + reader => 'should_auto_deref', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'type_constraint' => ( + reader => 'type_constraint', + predicate => 'has_type_constraint', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'trigger' => ( + reader => 'trigger', + predicate => 'has_trigger', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'handles' => ( + reader => 'handles', + writer => '_set_handles', + predicate => 'has_handles', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'documentation' => ( + reader => 'documentation', + predicate => 'has_documentation', + Class::MOP::_definition_context(), + ) +); + +1; + +# ABSTRACT: Core attributes shared by attribute metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Mixin::AttributeCore - Core attributes shared by attribute metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements the core attributes (aka properties) shared by all Moose +attributes. See the L<Moose::Meta::Attribute> documentation for API details. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Object/Trait.pm b/lib/Moose/Meta/Object/Trait.pm new file mode 100644 index 0000000..ed23f22 --- /dev/null +++ b/lib/Moose/Meta/Object/Trait.pm @@ -0,0 +1,107 @@ +package Moose::Meta::Object::Trait; +our $VERSION = '2.1405'; + +use Scalar::Util qw(blessed); + +sub _get_compatible_metaclass { + my $orig = shift; + my $self = shift; + return $self->$orig(@_) + || $self->_get_compatible_metaclass_by_role_reconciliation(@_); +} + +sub _get_compatible_metaclass_by_role_reconciliation { + my $self = shift; + my ($other_name) = @_; + my $meta_name = blessed($self) ? $self->_real_ref_name : $self; + + return unless Moose::Util::_classes_differ_by_roles_only( + $meta_name, $other_name + ); + + return Moose::Util::_reconcile_roles_for_metaclass( + $meta_name, $other_name + ); +} + +1; + +# ABSTRACT: Some overrides for L<Class::MOP::Object> functionality + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Object::Trait - Some overrides for L<Class::MOP::Object> functionality + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This module is entirely private, you shouldn't ever need to interact with +it directly. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm new file mode 100644 index 0000000..fbd8c1e --- /dev/null +++ b/lib/Moose/Meta/Role.pm @@ -0,0 +1,1095 @@ +package Moose::Meta::Role; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; + +use Moose::Meta::Class; +use Moose::Meta::Role::Attribute; +use Moose::Meta::Role::Method; +use Moose::Meta::Role::Method::Required; +use Moose::Meta::Role::Method::Conflicting; +use Moose::Meta::Method::Meta; +use Moose::Util qw/throw_exception/; +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Module', + 'Class::MOP::Mixin::HasAttributes', + 'Class::MOP::Mixin::HasMethods', + 'Class::MOP::Mixin::HasOverloads'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +## ------------------------------------------------------------------ +## NOTE: +## I normally don't do this, but I am doing +## a whole bunch of meta-programmin' in this +## module, so it just makes sense. For a clearer +## picture of what is going on in the next +## several lines of code, look at the really +## big comment at the end of this file (right +## before the POD). +## - SL +## ------------------------------------------------------------------ + +my $META = __PACKAGE__->meta; + +## ------------------------------------------------------------------ +## attributes ... + +# NOTE: +# since roles are lazy, we hold all the attributes +# of the individual role in 'stasis' until which +# time when it is applied to a class. This means +# keeping a lot of things in hash maps, so we are +# using a little of that meta-programmin' magic +# here and saving lots of extra typin'. And since +# many of these attributes above require similar +# functionality to support them, so we again use +# the wonders of meta-programmin' to deliver a +# very compact solution to this normally verbose +# problem. +# - SL + +foreach my $action ( + { + name => 'excluded_roles_map', + attr_reader => 'get_excluded_roles_map' , + methods => { + add => 'add_excluded_roles', + get_keys => 'get_excluded_roles_list', + existence => 'excludes_role', + } + }, + { + name => 'required_methods', + attr_reader => 'get_required_methods_map', + methods => { + remove => 'remove_required_methods', + get_values => 'get_required_method_list', + existence => 'requires_method', + } + }, +) { + + my $attr_reader = $action->{attr_reader}; + my $methods = $action->{methods}; + + # create the attribute + $META->add_attribute($action->{name} => ( + reader => $attr_reader, + default => sub { {} }, + Class::MOP::_definition_context(), + )); + + # create some helper methods + $META->add_method($methods->{add} => sub { + my ($self, @values) = @_; + $self->$attr_reader->{$_} = undef foreach @values; + }) if exists $methods->{add}; + + $META->add_method($methods->{get_keys} => sub { + my ($self) = @_; + keys %{$self->$attr_reader}; + }) if exists $methods->{get_keys}; + + $META->add_method($methods->{get_values} => sub { + my ($self) = @_; + values %{$self->$attr_reader}; + }) if exists $methods->{get_values}; + + $META->add_method($methods->{get} => sub { + my ($self, $name) = @_; + $self->$attr_reader->{$name} + }) if exists $methods->{get}; + + $META->add_method($methods->{existence} => sub { + my ($self, $name) = @_; + exists $self->$attr_reader->{$name} ? 1 : 0; + }) if exists $methods->{existence}; + + $META->add_method($methods->{remove} => sub { + my ($self, @values) = @_; + delete $self->$attr_reader->{$_} foreach @values; + }) if exists $methods->{remove}; +} + +$META->add_attribute( + 'method_metaclass', + reader => 'method_metaclass', + default => 'Moose::Meta::Role::Method', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'required_method_metaclass', + reader => 'required_method_metaclass', + default => 'Moose::Meta::Role::Method::Required', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'conflicting_method_metaclass', + reader => 'conflicting_method_metaclass', + default => 'Moose::Meta::Role::Method::Conflicting', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'application_to_class_class', + reader => 'application_to_class_class', + default => 'Moose::Meta::Role::Application::ToClass', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'application_to_role_class', + reader => 'application_to_role_class', + default => 'Moose::Meta::Role::Application::ToRole', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'application_to_instance_class', + reader => 'application_to_instance_class', + default => 'Moose::Meta::Role::Application::ToInstance', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'applied_attribute_metaclass', + reader => 'applied_attribute_metaclass', + default => 'Moose::Meta::Attribute', + Class::MOP::_definition_context(), +); + +# More or less copied from Moose::Meta::Class +sub initialize { + my $class = shift; + my @args = @_; + unshift @args, 'package' if @args % 2; + my %opts = @args; + my $package = delete $opts{package}; + return Class::MOP::get_metaclass_by_name($package) + || $class->SUPER::initialize($package, + 'attribute_metaclass' => 'Moose::Meta::Role::Attribute', + %opts, + ); +} + +sub reinitialize { + my $self = shift; + my $pkg = shift; + + my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); + + my %existing_classes; + if ($meta) { + %existing_classes = map { $_ => $meta->$_() } qw( + attribute_metaclass + method_metaclass + wrapped_method_metaclass + required_method_metaclass + conflicting_method_metaclass + application_to_class_class + application_to_role_class + application_to_instance_class + applied_attribute_metaclass + ); + } + + my %options = @_; + $options{weaken} = Class::MOP::metaclass_is_weak($meta->name) + if !exists $options{weaken} + && blessed($meta) + && $meta->isa('Moose::Meta::Role'); + + # don't need to remove generated metaobjects here yet, since we don't + # yet generate anything in roles. this may change in the future though... + # keep an eye on that + my $new_meta = $self->SUPER::reinitialize( + $pkg, + %existing_classes, + %options, + ); + $new_meta->_restore_metaobjects_from($meta) + if $meta && $meta->isa('Moose::Meta::Role'); + return $new_meta; +} + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->_restore_metamethods_from($old_meta); + $self->_restore_metaattributes_from($old_meta); + + for my $role ( @{ $old_meta->get_roles } ) { + $self->add_role($role); + } +} + +sub add_attribute { + my $self = shift; + + if (blessed $_[0] && ! $_[0]->isa('Moose::Meta::Role::Attribute') ) { + my $class = ref $_[0]; + throw_exception( CannotAddAsAnAttributeToARole => role_name => $self->name, + attribute_class => $class, + ); + } + elsif (!blessed($_[0]) && defined($_[0]) && $_[0] =~ /^\+(.*)/) { + throw_exception( AttributeExtensionIsNotSupportedInRoles => attribute_name => $_[0], + role_name => $self->name, + ); + } + + return $self->SUPER::add_attribute(@_); +} + +sub _attach_attribute { + my ( $self, $attribute ) = @_; + + $attribute->attach_to_role($self); +} + +sub add_required_methods { + my $self = shift; + + for (@_) { + my $method = $_; + if (!blessed($method)) { + $method = $self->required_method_metaclass->new( + name => $method, + ); + } + $self->get_required_methods_map->{$method->name} = $method; + } +} + +sub add_conflicting_method { + my $self = shift; + + my $method; + if (@_ == 1 && blessed($_[0])) { + $method = shift; + } + else { + $method = $self->conflicting_method_metaclass->new(@_); + } + + $self->add_required_methods($method); +} + +## ------------------------------------------------------------------ +## method modifiers + +# NOTE: +# the before/around/after method modifiers are +# stored by name, but there can be many methods +# then associated with that name. So again we have +# lots of similar functionality, so we can do some +# meta-programmin' and save some time. +# - SL + +foreach my $modifier_type (qw[ before around after ]) { + + my $attr_reader = "get_${modifier_type}_method_modifiers_map"; + + # create the attribute ... + $META->add_attribute("${modifier_type}_method_modifiers" => ( + reader => $attr_reader, + default => sub { {} }, + Class::MOP::_definition_context(), + )); + + # and some helper methods ... + $META->add_method("get_${modifier_type}_method_modifiers" => sub { + my ($self, $method_name) = @_; + #return () unless exists $self->$attr_reader->{$method_name}; + my $mm = $self->$attr_reader->{$method_name}; + $mm ? @$mm : (); + }); + + $META->add_method("has_${modifier_type}_method_modifiers" => sub { + my ($self, $method_name) = @_; + # NOTE: + # for now we assume that if it exists,.. + # it has at least one modifier in it + (exists $self->$attr_reader->{$method_name}) ? 1 : 0; + }); + + $META->add_method("add_${modifier_type}_method_modifier" => sub { + my ($self, $method_name, $method) = @_; + + $self->$attr_reader->{$method_name} = [] + unless exists $self->$attr_reader->{$method_name}; + + my $modifiers = $self->$attr_reader->{$method_name}; + + # NOTE: + # check to see that we aren't adding the + # same code twice. We err in favor of the + # first on here, this may not be as expected + foreach my $modifier (@{$modifiers}) { + return if $modifier == $method; + } + + push @{$modifiers} => $method; + }); + +} + +## ------------------------------------------------------------------ +## override method modifiers + +$META->add_attribute('override_method_modifiers' => ( + reader => 'get_override_method_modifiers_map', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +# NOTE: +# these are a little different because there +# can only be one per name, whereas the other +# method modifiers can have multiples. +# - SL + +sub add_override_method_modifier { + my ($self, $method_name, $method) = @_; + (!$self->has_method($method_name)) + || throw_exception( CannotOverrideALocalMethod => method_name => $method_name, + role_name => $self->name, + ); + $self->get_override_method_modifiers_map->{$method_name} = $method; +} + +sub has_override_method_modifier { + my ($self, $method_name) = @_; + # NOTE: + # for now we assume that if it exists,.. + # it has at least one modifier in it + (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0; +} + +sub get_override_method_modifier { + my ($self, $method_name) = @_; + $self->get_override_method_modifiers_map->{$method_name}; +} + +## general list accessor ... + +sub get_method_modifier_list { + my ($self, $modifier_type) = @_; + my $accessor = "get_${modifier_type}_method_modifiers_map"; + keys %{$self->$accessor}; +} + +sub _meta_method_class { 'Moose::Meta::Method::Meta' } + +## ------------------------------------------------------------------ +## subroles + +$META->add_attribute('roles' => ( + reader => 'get_roles', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +sub add_role { + my ($self, $role) = @_; + (blessed($role) && $role->isa('Moose::Meta::Role')) + || throw_exception( AddRoleToARoleTakesAMooseMetaRole => role_to_be_added => $role, + role_name => $self->name, + ); + push @{$self->get_roles} => $role; + $self->reset_package_cache_flag; +} + +sub calculate_all_roles { + my $self = shift; + my %seen; + grep { + !$seen{$_->name}++ + } ($self, map { + $_->calculate_all_roles + } @{ $self->get_roles }); +} + +sub does_role { + my ($self, $role) = @_; + (defined $role) + || throw_exception( RoleNameRequiredForMooseMetaRole => role_name => $self->name ); + my $role_name = blessed $role ? $role->name : $role; + # if we are it,.. then return true + return 1 if $role_name eq $self->name; + # otherwise.. check our children + foreach my $role (@{$self->get_roles}) { + return 1 if $role->does_role($role_name); + } + return 0; +} + +sub find_method_by_name { (shift)->get_method(@_) } + +## ------------------------------------------------------------------ +## role construction +## ------------------------------------------------------------------ + +sub apply { + my ($self, $other, %args) = @_; + + (blessed($other)) + || throw_exception( ApplyTakesABlessedInstance => param => $other, + role_name => $self->name, + ); + + my $application_class; + if ($other->isa('Moose::Meta::Role')) { + $application_class = $self->application_to_role_class; + } + elsif ($other->isa('Moose::Meta::Class')) { + $application_class = $self->application_to_class_class; + } + else { + $application_class = $self->application_to_instance_class; + } + + Moose::Util::_load_user_class($application_class); + + if ( exists $args{'-excludes'} ) { + # I wish we had coercion here :) + $args{'-excludes'} = ( + ref $args{'-excludes'} eq 'ARRAY' + ? $args{'-excludes'} + : [ $args{'-excludes'} ] + ); + } + + return $application_class->new(%args)->apply($self, $other, \%args); +} + +sub composition_class_roles { } + +sub combine { + my ($class, @role_specs) = @_; + + require Moose::Meta::Role::Composite; + + my (@roles, %role_params); + while (@role_specs) { + my ($role, $params) = @{ splice @role_specs, 0, 1 }; + my $requested_role + = blessed $role + ? $role + : Class::MOP::class_of($role); + + my $actual_role = $requested_role->_role_for_combination($params); + push @roles => $actual_role; + + next unless defined $params; + $role_params{$actual_role->name} = $params; + } + + my $c = Moose::Meta::Role::Composite->new(roles => \@roles); + return $c->apply_params(\%role_params); +} + +sub _role_for_combination { + my ($self, $params) = @_; + return $self; +} + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + (ref $options{attributes} eq 'HASH') + || throw_exception( CreateTakesHashRefOfAttributes => params => \%options, + attribute_class => $class + ) + if exists $options{attributes}; + + (ref $options{methods} eq 'HASH') + || throw_exception( CreateTakesHashRefOfMethods => params => \%options, + attribute_class => $class + ) + if exists $options{methods}; + + (ref $options{roles} eq 'ARRAY') + || throw_exception( CreateTakesArrayRefOfRoles => params => \%options, + attribute_class => $class + ) + if exists $options{roles}; + + my $package = delete $options{package}; + my $roles = delete $options{roles}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_add_meta_method($meta_name) + if defined $meta_name; + + if (defined $attributes) { + foreach my $attribute_name (keys %{$attributes}) { + my $attr = $attributes->{$attribute_name}; + $meta->add_attribute( + $attribute_name => blessed $attr ? $attr : %{$attr} ); + } + } + + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); + } + } + + if ($roles) { + Moose::Util::apply_all_roles($meta, @$roles); + } + + return $meta; +} + +sub consumers { + my $self = shift; + my @consumers; + for my $meta (Class::MOP::get_all_metaclass_instances) { + next if $meta->name eq $self->name; + next unless $meta->isa('Moose::Meta::Class') + || $meta->isa('Moose::Meta::Role'); + push @consumers, $meta->name + if $meta->does_role($self->name); + } + return @consumers; +} + +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' } + +sub create_anon_role { shift->create_anon(@_) } +sub is_anon_role { shift->is_anon(@_) } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + + # XXX fix this duplication (see MMC::_anon_cache_key + my $roles = Data::OptList::mkopt(($options{roles} || []), { + moniker => 'role', + val_test => sub { ref($_[0]) eq 'HASH' }, + }); + + my @role_keys; + for my $role_spec (@$roles) { + my ($role, $params) = @$role_spec; + $params = { %$params }; + + my $key = blessed($role) ? $role->name : $role; + + if ($params && %$params) { + my $alias = delete $params->{'-alias'} + || delete $params->{'alias'} + || {}; + my $excludes = delete $params->{'-excludes'} + || delete $params->{'excludes'} + || []; + $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; + + if (%$params) { + warn "Roles with parameters cannot be cached. Consider " + . "applying the parameters before calling " + . "create_anon_class, or using 'weaken => 0' instead"; + return; + } + + my $alias_key = join('%', + map { $_ => $alias->{$_} } sort keys %$alias + ); + my $excludes_key = join('%', + sort @$excludes + ); + $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; + } + + push @role_keys, $key; + } + + # Makes something like Role|Role::1 + return join('|', sort @role_keys); +} + +##################################################################### +## NOTE: +## This is Moose::Meta::Role as defined by Moose (plus the use of +## MooseX::AttributeHelpers module). It is here as a reference to +## make it easier to see what is happening above with all the meta +## programming. - SL +##################################################################### +# +# has 'roles' => ( +# metaclass => 'Array', +# reader => 'get_roles', +# isa => 'ArrayRef[Moose::Meta::Role]', +# default => sub { [] }, +# provides => { +# 'push' => 'add_role', +# } +# ); +# +# has 'excluded_roles_map' => ( +# metaclass => 'Hash', +# reader => 'get_excluded_roles_map', +# isa => 'HashRef[Str]', +# provides => { +# # Not exactly set, cause it sets multiple +# 'set' => 'add_excluded_roles', +# 'keys' => 'get_excluded_roles_list', +# 'exists' => 'excludes_role', +# } +# ); +# +# has 'required_methods' => ( +# metaclass => 'Hash', +# reader => 'get_required_methods_map', +# isa => 'HashRef[Moose::Meta::Role::Method::Required]', +# provides => { +# # not exactly set, or delete since it works for multiple +# 'set' => 'add_required_methods', +# 'delete' => 'remove_required_methods', +# 'keys' => 'get_required_method_list', +# 'exists' => 'requires_method', +# } +# ); +# +# # the before, around and after modifiers are +# # HASH keyed by method-name, with ARRAY of +# # CODE refs to apply in that order +# +# has 'before_method_modifiers' => ( +# metaclass => 'Hash', +# reader => 'get_before_method_modifiers_map', +# isa => 'HashRef[ArrayRef[CodeRef]]', +# provides => { +# 'keys' => 'get_before_method_modifiers', +# 'exists' => 'has_before_method_modifiers', +# # This actually makes sure there is an +# # ARRAY at the given key, and pushed onto +# # it. It also checks for duplicates as well +# # 'add' => 'add_before_method_modifier' +# } +# ); +# +# has 'after_method_modifiers' => ( +# metaclass => 'Hash', +# reader =>'get_after_method_modifiers_map', +# isa => 'HashRef[ArrayRef[CodeRef]]', +# provides => { +# 'keys' => 'get_after_method_modifiers', +# 'exists' => 'has_after_method_modifiers', +# # This actually makes sure there is an +# # ARRAY at the given key, and pushed onto +# # it. It also checks for duplicates as well +# # 'add' => 'add_after_method_modifier' +# } +# ); +# +# has 'around_method_modifiers' => ( +# metaclass => 'Hash', +# reader =>'get_around_method_modifiers_map', +# isa => 'HashRef[ArrayRef[CodeRef]]', +# provides => { +# 'keys' => 'get_around_method_modifiers', +# 'exists' => 'has_around_method_modifiers', +# # This actually makes sure there is an +# # ARRAY at the given key, and pushed onto +# # it. It also checks for duplicates as well +# # 'add' => 'add_around_method_modifier' +# } +# ); +# +# # override is similar to the other modifiers +# # except that it is not an ARRAY of code refs +# # but instead just a single name->code mapping +# +# has 'override_method_modifiers' => ( +# metaclass => 'Hash', +# reader =>'get_override_method_modifiers_map', +# isa => 'HashRef[CodeRef]', +# provides => { +# 'keys' => 'get_override_method_modifier', +# 'exists' => 'has_override_method_modifier', +# 'add' => 'add_override_method_modifier', # checks for local method .. +# } +# ); +# +##################################################################### + + +1; + +# ABSTRACT: The Moose Role metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role - The Moose Role metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Module> that provides +additional Moose-specific functionality. + +Its API looks a lot like L<Moose::Meta::Class>, but internally it +implements many things differently. This may change in the future. + +=head1 INHERITANCE + +C<Moose::Meta::Role> is a subclass of L<Class::MOP::Module>. + +=head1 METHODS + +=head2 Construction + +=over 4 + +=item B<< Moose::Meta::Role->initialize($role_name) >> + +This method creates a new role object with the provided name. + +=item B<< Moose::Meta::Role->combine( [ $role => { ... } ], [ $role ], ... ) >> + +This method accepts a list of array references. Each array reference +should contain a role name or L<Moose::Meta::Role> object as its first element. The second element is +an optional hash reference. The hash reference can contain C<-excludes> +and C<-alias> keys to control how methods are composed from the role. + +The return value is a new L<Moose::Meta::Role::Composite> that +represents the combined roles. + +=item B<< $metarole->composition_class_roles >> + +When combining multiple roles using C<combine>, this method is used to obtain a +list of role names to be applied to the L<Moose::Meta::Role::Composite> +instance returned by C<combine>. The default implementation returns an empty +list. Extensions that need to hook into role combination may wrap this method +to return additional role names. + +=item B<< Moose::Meta::Role->create($name, %options) >> + +This method is identical to the L<Moose::Meta::Class> C<create> +method. + +=item B<< Moose::Meta::Role->create_anon_role >> + +This method is identical to the L<Moose::Meta::Class> +C<create_anon_class> method. + +=item B<< $metarole->is_anon_role >> + +Returns true if the role is an anonymous role. + +=item B<< $metarole->consumers >> + +Returns a list of names of classes and roles which consume this role. + +=back + +=head2 Role application + +=over 4 + +=item B<< $metarole->apply( $thing, @options ) >> + +This method applies a role to the given C<$thing>. That can be another +L<Moose::Meta::Role>, object, a L<Moose::Meta::Class> object, or a +(non-meta) object instance. + +The options are passed directly to the constructor for the appropriate +L<Moose::Meta::Role::Application> subclass. + +Note that this will apply the role even if the C<$thing> in question already +C<does> this role. L<Moose::Util/does_role> is a convenient wrapper for +finding out if role application is necessary. + +=back + +=head2 Roles and other roles + +=over 4 + +=item B<< $metarole->get_roles >> + +This returns an array reference of roles which this role does. This +list may include duplicates. + +=item B<< $metarole->calculate_all_roles >> + +This returns a I<unique> list of all roles that this role does, and +all the roles that its roles do. + +=item B<< $metarole->does_role($role) >> + +Given a role I<name> or L<Moose::Meta::Role> object, returns true if this role +does the given role. + +=item B<< $metarole->add_role($role) >> + +Given a L<Moose::Meta::Role> object, this adds the role to the list of +roles that the role does. + +=item B<< $metarole->get_excluded_roles_list >> + +Returns a list of role names which this role excludes. + +=item B<< $metarole->excludes_role($role_name) >> + +Given a role I<name>, returns true if this role excludes the named +role. + +=item B<< $metarole->add_excluded_roles(@role_names) >> + +Given one or more role names, adds those roles to the list of excluded +roles. + +=back + +=head2 Methods + +The methods for dealing with a role's methods are all identical in API +and behavior to the same methods in L<Class::MOP::Class>. + +=over 4 + +=item B<< $metarole->method_metaclass >> + +Returns the method metaclass name for the role. This defaults to +L<Moose::Meta::Role::Method>. + +=item B<< $metarole->get_method($name) >> + +=item B<< $metarole->has_method($name) >> + +=item B<< $metarole->add_method( $name, $body ) >> + +=item B<< $metarole->get_method_list >> + +=item B<< $metarole->find_method_by_name($name) >> + +These methods are all identical to the methods of the same name in +L<Class::MOP::Package> + +=back + +=head2 Attributes + +As with methods, the methods for dealing with a role's attribute are +all identical in API and behavior to the same methods in +L<Class::MOP::Class>. + +However, attributes stored in this class are I<not> stored as +objects. Rather, the attribute definition is stored as a hash +reference. When a role is composed into a class, this hash reference +is passed directly to the metaclass's C<add_attribute> method. + +This is quite likely to change in the future. + +=over 4 + +=item B<< $metarole->get_attribute($attribute_name) >> + +=item B<< $metarole->has_attribute($attribute_name) >> + +=item B<< $metarole->get_attribute_list >> + +=item B<< $metarole->add_attribute($name, %options) >> + +=item B<< $metarole->remove_attribute($attribute_name) >> + +=back + +=head2 Overload introspection and creation + +The methods for dealing with a role's overloads are all identical in API and +behavior to the same methods in L<Class::MOP::Class>. + +=over 4 + +=item B<< $metarole->is_overloaded >> + +=item B<< $metarole->get_overloaded_operator($op) >> + +=item B<< $metarole->has_overloaded_operator($op) >> + +=item B<< $metarole->get_overload_list >> + +=item B<< $metarole->get_all_overloaded_operators >> + +=item B<< $metarole->add_overloaded_operator($op, $impl) >> + +=item B<< $metarole->remove_overloaded_operator($op) >> + +=back + +=head2 Required methods + +=over 4 + +=item B<< $metarole->get_required_method_list >> + +Returns the list of methods required by the role. + +=item B<< $metarole->requires_method($name) >> + +Returns true if the role requires the named method. + +=item B<< $metarole->add_required_methods(@names) >> + +Adds the named methods to the role's list of required methods. + +=item B<< $metarole->remove_required_methods(@names) >> + +Removes the named methods from the role's list of required methods. + +=item B<< $metarole->add_conflicting_method(%params) >> + +Instantiate the parameters as a L<Moose::Meta::Role::Method::Conflicting> +object, then add it to the required method list. + +=back + +=head2 Method modifiers + +These methods act like their counterparts in L<Class::MOP::Class> and +L<Moose::Meta::Class>. + +However, method modifiers are simply stored internally, and are not +applied until the role itself is applied to a class. + +=over 4 + +=item B<< $metarole->add_after_method_modifier($method_name, $method) >> + +=item B<< $metarole->add_around_method_modifier($method_name, $method) >> + +=item B<< $metarole->add_before_method_modifier($method_name, $method) >> + +=item B<< $metarole->add_override_method_modifier($method_name, $method) >> + +These methods all add an appropriate modifier to the internal list of +modifiers. + +=item B<< $metarole->has_after_method_modifiers >> + +=item B<< $metarole->has_around_method_modifiers >> + +=item B<< $metarole->has_before_method_modifiers >> + +=item B<< $metarole->has_override_method_modifier >> + +Return true if the role has any modifiers of the given type. + +=item B<< $metarole->get_after_method_modifiers($method_name) >> + +=item B<< $metarole->get_around_method_modifiers($method_name) >> + +=item B<< $metarole->get_before_method_modifiers($method_name) >> + +Given a method name, returns a list of the appropriate modifiers for +that method. + +=item B<< $metarole->get_override_method_modifier($method_name) >> + +Given a method name, returns the override method modifier for that +method, if it has one. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Moose::Meta::Role->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application.pm b/lib/Moose/Meta/Role/Application.pm new file mode 100644 index 0000000..58a123e --- /dev/null +++ b/lib/Moose/Meta/Role/Application.pm @@ -0,0 +1,225 @@ +package Moose::Meta::Role::Application; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; +use overload (); + +use List::Util 1.33 qw( all ); + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('method_exclusions' => ( + init_arg => '-excludes', + reader => 'get_method_exclusions', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('method_aliases' => ( + init_arg => '-alias', + reader => 'get_method_aliases', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub new { + my ($class, %params) = @_; + $class->_new(\%params); +} + +sub is_method_excluded { + my ($self, $method_name) = @_; + foreach (@{$self->get_method_exclusions}) { + return 1 if $_ eq $method_name; + } + return 0; +} + +sub is_method_aliased { + my ($self, $method_name) = @_; + exists $self->get_method_aliases->{$method_name} ? 1 : 0 +} + +sub is_aliased_method { + my ($self, $method_name) = @_; + my %aliased_names = reverse %{$self->get_method_aliases}; + exists $aliased_names{$method_name} ? 1 : 0; +} + +sub apply { + my $self = shift; + + $self->check_role_exclusions(@_); + $self->check_required_methods(@_); + $self->check_required_attributes(@_); + + $self->apply_overloading(@_); + $self->apply_attributes(@_); + $self->apply_methods(@_); + + $self->apply_override_method_modifiers(@_); + + $self->apply_before_method_modifiers(@_); + $self->apply_around_method_modifiers(@_); + $self->apply_after_method_modifiers(@_); +} + +sub check_role_exclusions { throw_exception( "CannotCallAnAbstractMethod" ); } +sub check_required_methods { throw_exception( "CannotCallAnAbstractMethod" ); } +sub check_required_attributes { throw_exception( "CannotCallAnAbstractMethod" ); } + +sub apply_attributes { throw_exception( "CannotCallAnAbstractMethod" ); } +sub apply_methods { throw_exception( "CannotCallAnAbstractMethod" ); } +sub apply_override_method_modifiers { throw_exception( "CannotCallAnAbstractMethod" ); } +sub apply_method_modifiers { throw_exception( "CannotCallAnAbstractMethod" ); } + +sub apply_before_method_modifiers { (shift)->apply_method_modifiers('before' => @_) } +sub apply_around_method_modifiers { (shift)->apply_method_modifiers('around' => @_) } +sub apply_after_method_modifiers { (shift)->apply_method_modifiers('after' => @_) } + +sub apply_overloading { + my ( $self, $role, $other ) = @_; + + return unless $role->is_overloaded; + + unless ( $other->is_overloaded ) { + $other->set_overload_fallback_value( + $role->get_overload_fallback_value ); + } + + for my $overload ( $role->get_all_overloaded_operators ) { + next if $other->has_overloaded_operator( $overload->operator ); + $other->add_overloaded_operator( + $overload->operator => $overload->clone ); + } +} + +1; + +# ABSTRACT: A base class for role application + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application - A base class for role application + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is the abstract base class for role applications. + +The API for this class and its subclasses still needs some +consideration, and is intentionally not yet documented. + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<get_method_exclusions> + +=item B<is_method_excluded> + +=item B<get_method_aliases> + +=item B<is_aliased_method> + +=item B<is_method_aliased> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_overloading> + +=item B<apply_method_modifiers> + +=item B<apply_before_method_modifiers> + +=item B<apply_after_method_modifiers> + +=item B<apply_around_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/RoleSummation.pm b/lib/Moose/Meta/Role/Application/RoleSummation.pm new file mode 100644 index 0000000..1276b66 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/RoleSummation.pm @@ -0,0 +1,440 @@ +package Moose::Meta::Role::Application::RoleSummation; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use List::Util 1.33 qw( all ); +use Scalar::Util 'blessed'; + +use Moose::Meta::Role::Composite; + +use parent 'Moose::Meta::Role::Application'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('role_params' => ( + reader => 'role_params', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub get_exclusions_for_role { + my ($self, $role) = @_; + $role = $role->name if blessed $role; + my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ? + '-excludes' : 'excludes'; + if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) { + if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') { + return $self->role_params->{$role}->{$excludes_key}; + } + return [ $self->role_params->{$role}->{$excludes_key} ]; + } + return []; +} + +sub get_method_aliases_for_role { + my ($self, $role) = @_; + $role = $role->name if blessed $role; + my $alias_key = exists $self->role_params->{$role}->{'-alias'} ? + '-alias' : 'alias'; + if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) { + return $self->role_params->{$role}->{$alias_key}; + } + return {}; +} + +sub is_method_excluded { + my ($self, $role, $method_name) = @_; + foreach ($self->get_exclusions_for_role($role->name)) { + return 1 if $_ eq $method_name; + } + return 0; +} + +sub is_method_aliased { + my ($self, $role, $method_name) = @_; + exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0 +} + +sub is_aliased_method { + my ($self, $role, $method_name) = @_; + my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)}; + exists $aliased_names{$method_name} ? 1 : 0; +} + +sub check_role_exclusions { + my ($self, $c) = @_; + + my %excluded_roles; + for my $role (@{ $c->get_roles }) { + my $name = $role->name; + + for my $excluded ($role->get_excluded_roles_list) { + push @{ $excluded_roles{$excluded} }, $name; + } + } + + foreach my $role (@{$c->get_roles}) { + foreach my $excluded (keys %excluded_roles) { + next unless $role->does_role($excluded); + + my @excluding = @{ $excluded_roles{$excluded} }; + + throw_exception( RoleExclusionConflict => roles => \@excluding, + role_name => $excluded + ); + } + } + + $c->add_excluded_roles(keys %excluded_roles); +} + +sub check_required_methods { + my ($self, $c) = @_; + + my %all_required_methods = + map { $_->name => $_ } + map { $_->get_required_method_list } + @{$c->get_roles}; + + foreach my $role (@{$c->get_roles}) { + foreach my $required (keys %all_required_methods) { + + delete $all_required_methods{$required} + if $role->has_method($required) + || $self->is_aliased_method($role, $required); + } + } + + $c->add_required_methods(values %all_required_methods); +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $c) = @_; + + my @all_attributes; + + for my $role ( @{ $c->get_roles } ) { + push @all_attributes, + map { $role->get_attribute($_) } $role->get_attribute_list; + } + + my %seen; + foreach my $attr (@all_attributes) { + my $name = $attr->name; + + if ( exists $seen{$name} ) { + next if $seen{$name}->is_same_as($attr); + + my $role1 = $seen{$name}->associated_role->name; + my $role2 = $attr->associated_role->name; + + throw_exception( AttributeConflictInSummation => attribute_name => $name, + role_name => $role1, + second_role_name => $role2, + ); + } + + $seen{$name} = $attr; + } + + foreach my $attr (@all_attributes) { + $c->add_attribute( $attr->clone ); + } +} + +sub apply_methods { + my ($self, $c) = @_; + + my @all_methods = map { + my $role = $_; + my $aliases = $self->get_method_aliases_for_role($role); + my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) }; + ( + (map { + exists $excludes{$_} ? () : + +{ + role => $role, + name => $_, + method => $role->get_method($_), + } + } map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } + $role->_get_local_methods), + (map { + +{ + role => $role, + name => $aliases->{$_}, + method => $role->get_method($_), + } + } keys %$aliases) + ); + } @{$c->get_roles}; + + my (%seen, %conflicts, %method_map); + foreach my $method (@all_methods) { + next if $conflicts{$method->{name}}; + my $seen = $seen{$method->{name}}; + + if ($seen) { + if ($seen->{method}->body != $method->{method}->body) { + $c->add_conflicting_method( + name => $method->{name}, + roles => [$method->{role}->name, $seen->{role}->name], + ); + + delete $method_map{$method->{name}}; + $conflicts{$method->{name}} = 1; + next; + } + } + + $seen{$method->{name}} = $method; + $method_map{$method->{name}} = $method->{method}; + } + + $c->add_method($_ => $method_map{$_}) for keys %method_map; +} + +sub apply_override_method_modifiers { + my ($self, $c) = @_; + + my @all_overrides = map { + my $role = $_; + map { + +{ + name => $_, + method => $role->get_override_method_modifier($_), + } + } $role->get_method_modifier_list('override'); + } @{$c->get_roles}; + + my %seen; + foreach my $override (@all_overrides) { + my @role_names = map { $_->name } @{$c->get_roles}; + if ( $c->has_method($override->{name}) ){ + throw_exception( OverrideConflictInSummation => role_names => \@role_names, + role_application => $self, + method_name => $override->{name} + ); + } + if (exists $seen{$override->{name}}) { + if ( $seen{$override->{name}} != $override->{method} ) { + throw_exception( OverrideConflictInSummation => role_names => \@role_names, + role_application => $self, + method_name => $override->{name}, + two_overrides_found => 1 + ); + } + } + $seen{$override->{name}} = $override->{method}; + } + + $c->add_override_method_modifier( + $_->{name}, $_->{method} + ) for @all_overrides; + +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $c) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $role (@{$c->get_roles}) { + foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { + $c->$add( + $method_name, + $_ + ) foreach $role->$get($method_name); + } + } +} + +sub apply_overloading { + my ( $self, $c ) = @_; + + my @overloaded_roles = grep { $_->is_overloaded } @{ $c->get_roles }; + return unless @overloaded_roles; + + my %fallback; + for my $role (@overloaded_roles) { + $fallback{ $role->name } = $role->get_overload_fallback_value; + } + + for my $role_name ( keys %fallback ) { + for my $other_role_name ( grep { $_ ne $role_name } keys %fallback ) { + my @fb_values = @fallback{ $role_name, $other_role_name }; + if ( all {defined} @fb_values ) { + next if $fallback{$role_name} eq $fallback{$other_role_name}; + throw_exception( + 'OverloadConflictInSummation', + role_names => [ $role_name, $other_role_name ], + role_application => $self, + overloaded_op => 'fallback', + ); + } + + next if all { !defined } @fb_values; + throw_exception( + 'OverloadConflictInSummation', + role_names => [ $role_name, $other_role_name ], + role_application => $self, + overloaded_op => 'fallback', + ); + } + } + + if ( keys %fallback ) { + $c->set_overload_fallback_value( ( values %fallback )[0] ); + } + + my %overload_map; + for my $role (@overloaded_roles) { + for my $overload ( $role->get_all_overloaded_operators ) { + $overload_map{ $overload->operator }{ $role->name } = $overload; + } + } + + for my $op_name ( keys %overload_map ) { + my @roles = keys %{ $overload_map{$op_name} }; + my $overload = $overload_map{$op_name}{ $roles[0] }; + + if ( @roles > 1 && !all { $overload->_is_equal_to($_) } + values %{ $overload_map{$op_name} } ) { + + throw_exception( + 'OverloadConflictInSummation', + role_names => [ @roles[ 0, 1 ] ], + role_application => $self, + overloaded_op => $op_name, + ); + } + + $c->add_overloaded_operator( + $op_name => $overload_map{$op_name}{ $roles[0] } ); + } +} + +1; + +# ABSTRACT: Combine two or more roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::RoleSummation - Combine two or more roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +Summation composes two traits, forming the union of non-conflicting +bindings and 'disabling' the conflicting bindings + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<role_params> + +=item B<get_exclusions_for_role> + +=item B<get_method_aliases_for_role> + +=item B<is_aliased_method> + +=item B<is_method_aliased> + +=item B<is_method_excluded> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_overloading> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm new file mode 100644 index 0000000..03eeedd --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -0,0 +1,314 @@ +package Moose::Meta::Role::Application::ToClass; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use List::Util 'first'; +use Moose::Util 'throw_exception'; +use Scalar::Util 'weaken'; + +use parent 'Moose::Meta::Role::Application'; + +__PACKAGE__->meta->add_attribute('role' => ( + reader => 'role', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('class' => ( + accessor => 'class', + Class::MOP::_definition_context(), +)); + +sub apply { + my ($self, $role, $class) = @_; + + # We need weak_ref in CMOP :( + weaken($self->{role} = $role); + weaken($self->{class} = $class); + + $self->SUPER::apply($role, $class); + + $class->add_role($role); + $class->add_role_application($self); +} + +sub check_role_exclusions { + my ($self, $role, $class) = @_; + if ($class->excludes_role($role->name)) { + throw_exception( ConflictDetectedInCheckRoleExclusionsInToClass => class_name => $class->name, + role_name => $role->name, + ); + } + foreach my $excluded_role_name ($role->get_excluded_roles_list) { + if ($class->does_role($excluded_role_name)) { + throw_exception( ClassDoesTheExcludedRole => role_name => $role->name, + excluded_role_name => $excluded_role_name, + class_name => $class->name, + ); + } + } +} + +sub check_required_methods { + my ($self, $role, $class) = @_; + + my @missing; + my @is_attr; + + # NOTE: + # we might need to move this down below the + # the attributes so that we can require any + # attribute accessors. However I am thinking + # that maybe those are somehow exempt from + # the require methods stuff. + foreach my $required_method ($role->get_required_method_list) { + my $required_method_name = $required_method->name; + + if (!$class->find_method_by_name($required_method_name)) { + + next if $self->is_aliased_method($required_method_name); + + push @missing, $required_method; + } + } + + return unless @missing; + + my $error = ''; + + @missing = sort { $a->name cmp $b->name } @missing; + my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing; + + if (@conflicts) { + my $conflict = $conflicts[0]; + my $roles = $conflict->roles_as_english_list; + + my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts; + + throw_exception( MethodNameConflictInRoles => conflict => \@same_role_conflicts, + class_name => $class->name + ); + } + elsif (@missing) { + if (my $meth = first { $class->name->can($_) } @missing) { + throw_exception( RequiredMethodsImportedByClass => class_name => $class->name, + role_name => $role->name, + missing_methods => \@missing, + imported_method => $meth + ); + } + else { + throw_exception( RequiredMethodsNotImplementedByClass => class_name => $class->name, + role_name => $role->name, + missing_methods => \@missing, + ); + } + } +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $role, $class) = @_; + + foreach my $attribute_name ($role->get_attribute_list) { + # it if it has one already + if ($class->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) { + next; + } + else { + $class->add_attribute( + $role->get_attribute($attribute_name)->attribute_for_class + ); + } + } +} + +sub apply_methods { + my ( $self, $role, $class ) = @_; + + foreach my $method ( $role->_get_local_methods ) { + my $method_name = $method->name; + + next if $method->isa('Class::MOP::Method::Meta'); + + unless ( $self->is_method_excluded($method_name) ) { + + my $class_method = $class->get_method($method_name); + + next if $class_method && $class_method->body != $method->body; + + $class->add_method( + $method_name, + $method, + ); + } + + next unless $self->is_method_aliased($method_name); + + my $aliased_method_name = $self->get_method_aliases->{$method_name}; + + my $class_method = $class->get_method($aliased_method_name); + + if ( $class_method && $class_method->body != $method->body ) { + throw_exception( CannotCreateMethodAliasLocalMethodIsPresentInClass => aliased_method_name => $aliased_method_name, + method => $method, + role_name => $role->name, + class_name => $class->name, + ); + } + + $class->add_method( + $aliased_method_name, + $method, + ); + } + + # we must reset the cache here since + # we are just aliasing methods, otherwise + # the modifiers go wonky. + $class->reset_package_cache_flag; +} + +sub apply_override_method_modifiers { + my ($self, $role, $class) = @_; + foreach my $method_name ($role->get_method_modifier_list('override')) { + # it if it has one already then ... + if ($class->has_method($method_name)) { + next; + } + else { + # if this is not a role, then we need to + # find the original package of the method + # so that we can tell the class were to + # find the right super() method + my $method = $role->get_override_method_modifier($method_name); + my ($package) = Class::MOP::get_code_info($method); + # if it is a class, we just add it + $class->add_override_method_modifier($method_name, $method, $package); + } + } +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $role, $class) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { + $class->$add( + $method_name, + $_ + ) foreach $role->$get($method_name); + } +} + +1; + +# ABSTRACT: Compose a role into a class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToClass - Compose a role into a class + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm new file mode 100644 index 0000000..5e82c45 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToInstance.pm @@ -0,0 +1,141 @@ +package Moose::Meta::Role::Application::ToInstance; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use List::Util 1.33 'all'; + +use parent 'Moose::Meta::Role::Application'; + +__PACKAGE__->meta->add_attribute('rebless_params' => ( + reader => 'rebless_params', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +use constant _NEED_OVERLOAD_HACK_FOR_OBJECTS => $] < 5.008009; + +sub apply { + my ( $self, $role, $object, $args ) = @_; + + my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class'; + + # This is a special case to handle the case where the object's metaclass + # is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example, + # when applying a role to a Moose::Meta::Attribute object). + $obj_meta = 'Moose::Meta::Class' + unless $obj_meta->isa('Moose::Meta::Class'); + + my $class = $obj_meta->create_anon_class( + superclasses => [ blessed($object) ], + roles => [ $role, keys(%$args) ? ($args) : () ], + cache => (all { $_ eq '-alias' || $_ eq '-excludes' } keys %$args), + ); + + $class->rebless_instance( $object, %{ $self->rebless_params } ); + + if ( _NEED_OVERLOAD_HACK_FOR_OBJECTS + && overload::Overloaded( ref $object ) ) { + + # need to use $_[2] here to apply to the object in the caller + _reset_amagic($_[2]); + } + + return $object; +} + +1; + +# ABSTRACT: Compose a role into an instance + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToInstance - Compose a role into an instance + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<rebless_params> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm new file mode 100644 index 0000000..0d8af91 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToRole.pm @@ -0,0 +1,283 @@ +package Moose::Meta::Role::Application::ToRole; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use parent 'Moose::Meta::Role::Application'; + +use Moose::Util 'throw_exception'; + +sub apply { + my ($self, $role1, $role2) = @_; + $self->SUPER::apply($role1, $role2); + $role2->add_role($role1); +} + +sub check_role_exclusions { + my ($self, $role1, $role2) = @_; + if ( $role2->excludes_role($role1->name) ) { + throw_exception( ConflictDetectedInCheckRoleExclusions => role_name => $role2->name, + excluded_role_name => $role1->name, + ); + } + foreach my $excluded_role_name ($role1->get_excluded_roles_list) { + if ( $role2->does_role($excluded_role_name) ) { + throw_exception( RoleDoesTheExcludedRole => role_name => $role2->name, + excluded_role_name => $excluded_role_name, + second_role_name => $role1->name, + ); + } + $role2->add_excluded_roles($excluded_role_name); + } +} + +sub check_required_methods { + my ($self, $role1, $role2) = @_; + foreach my $required_method ($role1->get_required_method_list) { + my $required_method_name = $required_method->name; + + next if $self->is_aliased_method($required_method_name); + + $role2->add_required_methods($required_method) + unless $role2->find_method_by_name($required_method_name); + } +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $role1, $role2) = @_; + foreach my $attribute_name ($role1->get_attribute_list) { + # it if it has one already + if ($role2->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) { + + my $role2_name = $role2->name; + + throw_exception( AttributeConflictInRoles => role_name => $role1->name, + second_role_name => $role2->name, + attribute_name => $attribute_name + ); + } + else { + $role2->add_attribute( + $role1->get_attribute($attribute_name)->clone + ); + } + } +} + +sub apply_methods { + my ( $self, $role1, $role2 ) = @_; + foreach my $method ( $role1->_get_local_methods ) { + + my $method_name = $method->name; + + next if $method->isa('Class::MOP::Method::Meta'); + + unless ( $self->is_method_excluded($method_name) ) { + + my $role2_method = $role2->get_method($method_name); + if ( $role2_method + && $role2_method->body != $method->body ) { + + # method conflicts between roles used to result in the method + # becoming a requirement but now are permitted just like + # for classes, hence no code in this branch anymore. + } + else { + $role2->add_method( + $method_name, + $method, + ); + } + } + + next unless $self->is_method_aliased($method_name); + + my $aliased_method_name = $self->get_method_aliases->{$method_name}; + + my $role2_method = $role2->get_method($aliased_method_name); + + if ( $role2_method + && $role2_method->body != $method->body ) { + + throw_exception( CannotCreateMethodAliasLocalMethodIsPresent => aliased_method_name => $aliased_method_name, + method => $method, + role_name => $role2->name, + role_being_applied_name => $role1->name, + ); + } + + $role2->add_method( + $aliased_method_name, + $role1->get_method($method_name) + ); + + if ( !$role2->has_method($method_name) ) { + $role2->add_required_methods($method_name) + unless $self->is_method_excluded($method_name); + } + } +} + +sub apply_override_method_modifiers { + my ($self, $role1, $role2) = @_; + foreach my $method_name ($role1->get_method_modifier_list('override')) { + # it if it has one already then ... + if ($role2->has_method($method_name)) { + # if it is being composed into another role + # we have a conflict here, because you cannot + # combine an overridden method with a locally + # defined one + throw_exception( OverrideConflictInComposition => role_name => $role2->name, + role_being_applied_name => $role1->name, + method_name => $method_name + ); + } + else { + # if we are a role, we need to make sure + # we don't have a conflict with the role + # we are composing into + if ($role2->has_override_method_modifier($method_name) && + $role1->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) { + + throw_exception( OverrideConflictInComposition => role_name => $role2->name, + role_being_applied_name => $role1->name, + method_name => $method_name, + two_overrides_found => 1 + ); + } + else { + # if there is no conflict, + # just add it to the role + $role2->add_override_method_modifier( + $method_name, + $role1->get_override_method_modifier($method_name) + ); + } + } + } +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $role1, $role2) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) { + $role2->$add( + $method_name, + $_ + ) foreach $role1->$get($method_name); + } +} + +1; + +# ABSTRACT: Compose a role into another role + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToRole - Compose a role into another role + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Attribute.pm b/lib/Moose/Meta/Role/Attribute.pm new file mode 100644 index 0000000..0c09550 --- /dev/null +++ b/lib/Moose/Meta/Role/Attribute.pm @@ -0,0 +1,263 @@ +package Moose::Meta::Role::Attribute; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util 1.33 'all'; +use Scalar::Util 'blessed', 'weaken'; + +use parent 'Moose::Meta::Mixin::AttributeCore', 'Class::MOP::Object'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute( + 'metaclass' => ( + reader => 'metaclass', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'associated_role' => ( + reader => 'associated_role', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + '_original_role' => ( + reader => '_original_role', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'is' => ( + reader => 'is', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'original_options' => ( + reader => 'original_options', + Class::MOP::_definition_context(), + ) +); + +sub new { + my ( $class, $name, %options ) = @_; + + (defined $name) + || throw_exception( MustProvideANameForTheAttribute => params => \%options, + class => $class + ); + + my $role = delete $options{_original_role}; + + return bless { + name => $name, + original_options => \%options, + _original_role => $role, + %options, + }, $class; +} + +sub attach_to_role { + my ( $self, $role ) = @_; + + ( blessed($role) && $role->isa('Moose::Meta::Role') ) + || throw_exception( MustPassAMooseMetaRoleInstanceOrSubclass => class => $self, + role => $role + ); + + weaken( $self->{'associated_role'} = $role ); +} + +sub original_role { + my $self = shift; + + return $self->_original_role || $self->associated_role; +} + +sub attribute_for_class { + my $self = shift; + + my $metaclass = $self->original_role->applied_attribute_metaclass; + + return $metaclass->interpolate_class_and_new( + $self->name => %{ $self->original_options } ); +} + +sub clone { + my $self = shift; + + my $role = $self->original_role; + + return ( ref $self )->new( + $self->name, + %{ $self->original_options }, + _original_role => $role, + ); +} + +sub is_same_as { + my $self = shift; + my $attr = shift; + + my $self_options = $self->original_options; + my $other_options = $attr->original_options; + + return 0 + unless ( join q{|}, sort keys %{$self_options} ) eq ( join q{|}, sort keys %{$other_options} ); + + for my $key ( keys %{$self_options} ) { + return 0 if defined $self_options->{$key} && ! defined $other_options->{$key}; + return 0 if ! defined $self_options->{$key} && defined $other_options->{$key}; + + next if all { ! defined } $self_options->{$key}, $other_options->{$key}; + + return 0 unless $self_options->{$key} eq $other_options->{$key}; + } + + return 1; +} + +1; + +# ABSTRACT: The Moose attribute metaclass for Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Attribute - The Moose attribute metaclass for Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements the API for attributes in roles. Attributes in roles are +more like attribute prototypes than full blown attributes. While they are +introspectable, they have very little behavior. + +=head1 METHODS + +This class provides the following methods: + +=over 4 + +=item B<< Moose::Meta::Role::Attribute->new(...) >> + +This method accepts all the options that would be passed to the constructor +for L<Moose::Meta::Attribute>. + +=item B<< $attr->metaclass >> + +=item B<< $attr->is >> + +Returns the option as passed to the constructor. + +=item B<< $attr->associated_role >> + +Returns the L<Moose::Meta::Role> to which this attribute belongs, if any. + +=item B<< $attr->original_role >> + +Returns the L<Moose::Meta::Role> in which this attribute was first +defined. This may not be the same as the value of C<associated_role()> for +attributes in a composite role, or when one role consumes other roles. + +=item B<< $attr->original_options >> + +Returns a hash reference of options passed to the constructor. This is used +when creating a L<Moose::Meta::Attribute> object from this object. + +=item B<< $attr->attach_to_role($role) >> + +Attaches the attribute to the given L<Moose::Meta::Role>. + +=item B<< $attr->attribute_for_class($metaclass) >> + +Given an attribute metaclass name, this method calls C<< +$metaclass->interpolate_class_and_new >> to construct an attribute object +which can be added to a L<Moose::Meta::Class>. + +=item B<< $attr->clone >> + +Creates a new object identical to the object on which the method is called. + +=item B<< $attr->is_same_as($other_attr) >> + +Compares two role attributes and returns true if they are identical. + +=back + +In addition, this class implements all informational predicates implements by +L<Moose::Meta::Attribute> (and L<Class::MOP::Attribute>). + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Composite.pm b/lib/Moose/Meta/Role/Composite.pm new file mode 100644 index 0000000..40e0dad --- /dev/null +++ b/lib/Moose/Meta/Role/Composite.pm @@ -0,0 +1,324 @@ +package Moose::Meta::Role::Composite; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use Moose::Util 'throw_exception'; +use parent 'Moose::Meta::Role'; + +# NOTE: +# we need to override the ->name +# method from Class::MOP::Package +# since we don't have an actual +# package for this. +# - SL +__PACKAGE__->meta->add_attribute('name' => ( + reader => 'name', + Class::MOP::_definition_context(), +)); + +# NOTE: +# Again, since we don't have a real +# package to store our methods in, +# we use a HASH ref instead. +# - SL +__PACKAGE__->meta->add_attribute('_methods' => ( + reader => '_method_map', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_overloads' => ( + reader => '_overload_map', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_overload_fallback' => ( + accessor => '_overload_fallback', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute( + 'application_role_summation_class', + reader => 'application_role_summation_class', + default => 'Moose::Meta::Role::Application::RoleSummation', + Class::MOP::_definition_context(), +); + +sub new { + my ($class, %params) = @_; + + # the roles param is required ... + foreach ( @{$params{roles}} ) { + unless ( $_->isa('Moose::Meta::Role') ) { + throw_exception( RolesListMustBeInstancesOfMooseMetaRole => params => \%params, + role => $_, + class => $class + ); + } + } + + my @composition_roles = map { + $_->composition_class_roles + } @{ $params{roles} }; + + if (@composition_roles) { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ $class ], + roles => [ @composition_roles ], + cache => 1, + ); + $class = $meta->name; + } + + # and the name is created from the + # roles if one has not been provided + $params{name} ||= (join "|" => map { $_->name } @{$params{roles}}); + $class->_new(\%params); +} + +# There's no such thing as an anonymous composite role since composites are an +# artifact of Moose's internals. However, a composite role that contains an +# anon role may _look_ like an anon role since $self->name =~ /$anon_key/ can +# return true if the first role in the composite is anonymous itself. +sub is_anon { 0 } + +# This is largely a copy of what's in Moose::Meta::Role (itself +# largely a copy of Class::MOP::Class). However, we can't actually +# call add_package_symbol, because there's no package into which to +# add the symbol. +sub add_method { + my ($self, $method_name, $method) = @_; + + unless ( defined $method_name && $method_name ) { + throw_exception( MustDefineAMethodName => instance => $self ); + } + + my $body; + if (blessed($method)) { + $body = $method->body; + if ($method->package_name ne $self->name) { + $method = $method->clone( + package_name => $self->name, + name => $method_name + ) if $method->can('clone'); + } + } + else { + $body = $method; + $method = $self->wrap_method_body( body => $body, name => $method_name ); + } + + $self->_method_map->{$method_name} = $method; +} + +sub get_method_list { + my $self = shift; + return keys %{ $self->_method_map }; +} + +sub _get_local_methods { + my $self = shift; + return values %{ $self->_method_map }; +} + +sub has_method { + my ($self, $method_name) = @_; + + return exists $self->_method_map->{$method_name}; +} + +sub get_method { + my ($self, $method_name) = @_; + + return $self->_method_map->{$method_name}; +} + +sub is_overloaded { + my ($self) = @_; + return keys %{ $self->_overload_map }; +} + +sub add_overloaded_operator { + my ( $self, $op_name, $overload ) = @_; + + unless ( defined $op_name && $op_name ) { + throw_exception( + 'MustDefineAnOverloadOperator', + instance => $self, + ); + } + + $self->_overload_map->{$op_name} = $overload; +} + +sub get_overload_fallback_value { + my ($self) = @_; + return $self->_overload_fallback; +} + +sub set_overload_fallback_value { + my $self = shift; + $self->_overload_fallback(shift); +} + +sub get_all_overloaded_operators { + my ( $self, $method_name ) = @_; + return values %{ $self->_overload_map }; +} + +sub apply_params { + my ($self, $role_params) = @_; + Moose::Util::_load_user_class($self->application_role_summation_class); + + $self->application_role_summation_class->new( + role_params => $role_params, + )->apply($self); + + return $self; +} + +sub reinitialize { + my ( $class, $old_meta, @args ) = @_; + + throw_exception( CannotInitializeMooseMetaRoleComposite => old_meta => $old_meta, + args => \@args, + role_composite => $class + ) + if !blessed $old_meta + || !$old_meta->isa('Moose::Meta::Role::Composite'); + + my %existing_classes = map { $_ => $old_meta->$_() } qw( + application_role_summation_class + ); + + return $old_meta->meta->clone_object( $old_meta, %existing_classes, @args ); +} + +1; + +# ABSTRACT: An object to represent the set of roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Composite - An object to represent the set of roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +A composite is a role that consists of a set of two or more roles. + +The API of a composite role is almost identical to that of a regular +role. + +=head1 INHERITANCE + +C<Moose::Meta::Role::Composite> is a subclass of L<Moose::Meta::Role>. + +=head2 METHODS + +=over 4 + +=item B<< Moose::Meta::Role::Composite->new(%options) >> + +This returns a new composite role object. It accepts the same +options as its parent class, with a few changes: + +=over 8 + +=item * roles + +This option is an array reference containing a list of +L<Moose::Meta::Role> object. This is a required option. + +=item * name + +If a name is not given, one is generated from the roles provided. + +=item * apply_params(\%role_params) + +Creates a new RoleSummation role application with C<%role_params> and applies +the composite role to it. The RoleSummation role application class used is +determined by the composite role's C<application_role_summation_class> +attribute. + +=item * reinitialize($metaclass) + +Like C<< Class::MOP::Package->reinitialize >>, but doesn't allow passing a +string with the package name, as there is no real package for composite roles. + +=back + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Method.pm b/lib/Moose/Meta/Role/Method.pm new file mode 100644 index 0000000..5dff6f4 --- /dev/null +++ b/lib/Moose/Meta/Role/Method.pm @@ -0,0 +1,101 @@ +package Moose::Meta::Role::Method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method'; + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is blah blah blah + # see the comments in CMOP::Method::Meta and CMOP::Method::Wrapped + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: A Moose Method metaclass for Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Method - A Moose Method metaclass for Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is primarily used to mark methods coming from a role +as being different. Right now it is nothing but a subclass +of L<Moose::Meta::Method>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Method/Conflicting.pm b/lib/Moose/Meta/Role/Method/Conflicting.pm new file mode 100644 index 0000000..9d810fc --- /dev/null +++ b/lib/Moose/Meta/Role/Method/Conflicting.pm @@ -0,0 +1,139 @@ +package Moose::Meta::Role::Method::Conflicting; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util; + +use parent 'Moose::Meta::Role::Method::Required'; + +__PACKAGE__->meta->add_attribute('roles' => ( + reader => 'roles', + required => 1, + Class::MOP::_definition_context(), +)); + +sub roles_as_english_list { + my $self = shift; + Moose::Util::english_list( map { q{'} . $_ . q{'} } @{ $self->roles } ); +} + +1; + +# ABSTRACT: A Moose metaclass for conflicting methods in Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Method::Conflicting - A Moose metaclass for conflicting methods in Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head1 INHERITANCE + +C<Moose::Meta::Role::Method::Conflicting> is a subclass of +L<Moose::Meta::Role::Method::Required>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Role::Method::Conflicting->new(%options) >> + +This creates a new type constraint based on the provided C<%options>: + +=over 8 + +=item * name + +The method name. This is required. + +=item * roles + +The list of role names that generated the conflict. This is required. + +=back + +=item B<< $method->name >> + +Returns the conflicting method's name, as provided to the constructor. + +=item B<< $method->roles >> + +Returns the roles that generated this conflicting method, as provided to the +constructor. + +=item B<< $method->roles_as_english_list >> + +Returns the roles that generated this conflicting method as an English list. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Method/Required.pm b/lib/Moose/Meta/Role/Method/Required.pm new file mode 100644 index 0000000..ebdd366 --- /dev/null +++ b/lib/Moose/Meta/Role/Method/Required.pm @@ -0,0 +1,129 @@ +package Moose::Meta::Role::Method::Required; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use overload '""' => sub { shift->name }, # stringify to method name + fallback => 1; + +use parent 'Class::MOP::Object'; + +# This is not a Moose::Meta::Role::Method because it has no implementation, it +# is just a name + +__PACKAGE__->meta->add_attribute('name' => ( + reader => 'name', + required => 1, + Class::MOP::_definition_context(), +)); + +sub new { shift->_new(@_) } + +1; + +# ABSTRACT: A Moose metaclass for required methods in Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Method::Required - A Moose metaclass for required methods in Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head1 INHERITANCE + +C<Moose::Meta::Role::Method::Required> is a subclass of L<Class::MOP::Object>. +It is B<not> a subclass of C<Moose::Meta::Role::Method> since it does not +provide an implementation of the method. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Role::Method::Required->new(%options) >> + +This creates a new type constraint based on the provided C<%options>: + +=over 8 + +=item * name + +The method name. This is required. + +=back + +=item B<< $method->name >> + +Returns the required method's name, as provided to the constructor. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeCoercion.pm b/lib/Moose/Meta/TypeCoercion.pm new file mode 100644 index 0000000..58317bc --- /dev/null +++ b/lib/Moose/Meta/TypeCoercion.pm @@ -0,0 +1,243 @@ +package Moose::Meta::TypeCoercion; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Moose::Meta::Attribute; +use Moose::Util::TypeConstraints (); + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('type_coercion_map' => ( + reader => 'type_coercion_map', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute( + Moose::Meta::Attribute->new('type_constraint' => ( + reader => 'type_constraint', + weak_ref => 1, + Class::MOP::_definition_context(), + )) +); + +# private accessor +__PACKAGE__->meta->add_attribute('compiled_type_coercion' => ( + accessor => '_compiled_type_coercion', + Class::MOP::_definition_context(), +)); + +sub new { + my $class = shift; + my $self = Class::MOP::class_of($class)->new_object(@_); + $self->compile_type_coercion; + return $self; +} + +sub compile_type_coercion { + my $self = shift; + my @coercion_map = @{$self->type_coercion_map}; + my @coercions; + while (@coercion_map) { + my ($constraint_name, $action) = splice(@coercion_map, 0, 2); + my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name); + + unless ( defined $type_constraint ) { + throw_exception( CouldNotFindTypeConstraintToCoerceFrom => constraint_name => $constraint_name, + instance => $self + ); + } + + push @coercions => [ + $type_constraint->_compiled_type_constraint, + $action + ]; + } + $self->_compiled_type_coercion(sub { + my $thing = shift; + foreach my $coercion (@coercions) { + my ($constraint, $converter) = @$coercion; + if ($constraint->($thing)) { + local $_ = $thing; + return $converter->($thing); + } + } + return $thing; + }); +} + +sub has_coercion_for_type { + my ($self, $type_name) = @_; + my %coercion_map = @{$self->type_coercion_map}; + exists $coercion_map{$type_name} ? 1 : 0; +} + +sub add_type_coercions { + my ($self, @new_coercion_map) = @_; + + my $coercion_map = $self->type_coercion_map; + my %has_coercion = @$coercion_map; + + while (@new_coercion_map) { + my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2); + + if ( exists $has_coercion{$constraint_name} ) { + throw_exception( CoercionAlreadyExists => constraint_name => $constraint_name, + instance => $self + ); + } + + push @{$coercion_map} => ($constraint_name, $action); + } + + # and re-compile ... + $self->compile_type_coercion; +} + +sub coerce { $_[0]->_compiled_type_coercion->($_[1]) } + + +1; + +# ABSTRACT: The Moose Type Coercion metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeCoercion - The Moose Type Coercion metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +A type coercion object is basically a mapping of one or more type +constraints and the associated coercions subroutines. + +It's unlikely that you will need to instantiate an object of this +class directly, as it's part of the deep internals of Moose. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeCoercion->new(%options) >> + +Creates a new type coercion object, based on the options provided. + +=over 8 + +=item * type_constraint + +This is the L<Moose::Meta::TypeConstraint> object for the type that is +being coerced I<to>. + +=back + +=item B<< $coercion->type_coercion_map >> + +This returns the map of type constraints to coercions as an array +reference. The values of the array alternate between type names and +subroutine references which implement the coercion. + +The value is an array reference because coercions are tried in the +order they are added. + +=item B<< $coercion->type_constraint >> + +This returns the L<Moose::Meta::TypeConstraint> that was passed to the +constructor. + +=item B<< $coercion->has_coercion_for_type($type_name) >> + +Returns true if the coercion can coerce the named type. + +=item B<< $coercion->add_type_coercions( $type_name => $sub, ... ) >> + +This method takes a list of type names and subroutine references. If +the coercion already has a mapping for a given type, it throws an +exception. + +Coercions are actually + +=item B<< $coercion->coerce($value) >> + +This method takes a value and applies the first valid coercion it +finds. + +This means that if the value could belong to more than type in the +coercion object, the first coercion added is used. + +=item B<< Moose::Meta::TypeCoercion->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeCoercion/Union.pm b/lib/Moose/Meta/TypeCoercion/Union.pm new file mode 100644 index 0000000..5ef179d --- /dev/null +++ b/lib/Moose/Meta/TypeCoercion/Union.pm @@ -0,0 +1,145 @@ +package Moose::Meta::TypeCoercion::Union; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; + +use parent 'Moose::Meta::TypeCoercion'; + +use Moose::Util 'throw_exception'; + +sub compile_type_coercion { + my $self = shift; + my $type_constraint = $self->type_constraint; + + (blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union')) + || throw_exception( NeedsTypeConstraintUnionForTypeCoercionUnion => type_coercion_union_object => $self, + type_name => $type_constraint->name + ); + + $self->_compiled_type_coercion( + sub { + my $value = shift; + + foreach my $type ( grep { $_->has_coercion } + @{ $type_constraint->type_constraints } ) { + my $temp = $type->coerce($value); + return $temp if $type_constraint->check($temp); + } + + return $value; + } + ); +} + +sub has_coercion_for_type { 0 } + +sub add_type_coercions { + my $self = shift; + throw_exception( CannotAddAdditionalTypeCoercionsToUnion => type_coercion_union_object => $self ); +} + +1; + +# ABSTRACT: The Moose Type Coercion metaclass for Unions + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeCoercion::Union - The Moose Type Coercion metaclass for Unions + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a subclass of L<Moose::Meta::TypeCoercion> that is used for +L<Moose::Meta::TypeConstraint::Union> objects. + +=head1 METHODS + +=over 4 + +=item B<< $coercion->has_coercion_for_type >> + +This method always returns false. + +=item B<< $coercion->add_type_coercions >> + +This method always throws an error. You cannot add coercions to a +union type coercion. + +=item B<< $coercion->coerce($value) >> + +This method will coerce by trying the coercions for each type in the +union. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm new file mode 100644 index 0000000..e943eec --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -0,0 +1,604 @@ +package Moose::Meta::TypeConstraint; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use overload '0+' => sub { refaddr(shift) }, # id an object + '""' => sub { shift->name }, # stringify to tc name + bool => sub { 1 }, + fallback => 1; + +use Eval::Closure; +use Scalar::Util qw(refaddr); +use Sub::Name qw(subname); +use Try::Tiny; + +use base 'Class::MOP::Object'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('name' => ( + reader => 'name', + Class::MOP::_definition_context(), +)); +__PACKAGE__->meta->add_attribute('parent' => ( + reader => 'parent', + predicate => 'has_parent', + Class::MOP::_definition_context(), +)); + +my $null_constraint = sub { 1 }; +__PACKAGE__->meta->add_attribute('constraint' => ( + reader => 'constraint', + writer => '_set_constraint', + default => sub { $null_constraint }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('message' => ( + accessor => 'message', + predicate => 'has_message', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_default_message' => ( + accessor => '_default_message', + Class::MOP::_definition_context(), +)); + +# can't make this a default because it has to close over the type name, and +# cmop attributes don't have lazy +my $_default_message_generator = sub { + my $name = shift; + sub { + my $value = shift; + # have to load it late like this, since it uses Moose itself + my $can_partialdump = try { + # versions prior to 0.14 had a potential infinite loop bug + require Devel::PartialDump; + Devel::PartialDump->VERSION(0.14); + 1; + }; + if ($can_partialdump) { + $value = Devel::PartialDump->new->dump($value); + } + else { + $value = (defined $value ? overload::StrVal($value) : 'undef'); + } + return "Validation failed for '" . $name . "' with value $value"; + } +}; +__PACKAGE__->meta->add_attribute('coercion' => ( + accessor => 'coercion', + predicate => 'has_coercion', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('inlined' => ( + init_arg => 'inlined', + accessor => 'inlined', + predicate => '_has_inlined_type_constraint', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('inline_environment' => ( + init_arg => 'inline_environment', + accessor => '_inline_environment', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub parents { + my $self = shift; + $self->parent; +} + +# private accessors + +__PACKAGE__->meta->add_attribute('compiled_type_constraint' => ( + accessor => '_compiled_type_constraint', + predicate => '_has_compiled_type_constraint', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('package_defined_in' => ( + accessor => '_package_defined_in', + Class::MOP::_definition_context(), +)); + +sub new { + my $class = shift; + my ($first, @rest) = @_; + my %args = ref $first ? %$first : $first ? ($first, @rest) : (); + $args{name} = $args{name} ? "$args{name}" : "__ANON__"; + + if ( exists $args{message} + && (!ref($args{message}) || ref($args{message}) ne 'CODE') ) { + throw_exception( MessageParameterMustBeCodeRef => params => \%args, + class => $class + ); + } + + my $self = $class->_new(%args); + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + $self->_default_message($_default_message_generator->($self->name)) + unless $self->has_message; + return $self; +} + + + +sub coerce { + my $self = shift; + + my $coercion = $self->coercion; + + unless ($coercion) { + throw_exception( CoercingWithoutCoercions => type_name => $self->name ); + } + + return $_[0] if $self->check($_[0]); + + return $coercion->coerce(@_); +} + +sub assert_coerce { + my $self = shift; + + my $result = $self->coerce(@_); + + $self->assert_valid($result); + + return $result; +} + +sub check { + my ($self, @args) = @_; + my $constraint_subref = $self->_compiled_type_constraint; + return $constraint_subref->(@args) ? 1 : undef; +} + +sub validate { + my ($self, $value) = @_; + if ($self->_compiled_type_constraint->($value)) { + return undef; + } + else { + $self->get_message($value); + } +} + +sub can_be_inlined { + my $self = shift; + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->can_be_inlined; + } + + return $self->_has_inlined_type_constraint; +} + +sub _inline_check { + my $self = shift; + + unless ( $self->can_be_inlined ) { + throw_exception( CannotInlineTypeConstraintCheck => type_name => $self->name ); + } + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->_inline_check(@_); + } + + return '( do { ' . $self->inlined->( $self, @_ ) . ' } )'; +} + +sub inline_environment { + my $self = shift; + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->inline_environment; + } + + return $self->_inline_environment; +} + +sub assert_valid { + my ( $self, $value ) = @_; + + return 1 if $self->check($value); + + throw_exception( + 'ValidationFailedForTypeConstraint', + type => $self, + value => $value + ); +} + +sub get_message { + my ($self, $value) = @_; + my $msg = $self->has_message + ? $self->message + : $self->_default_message; + local $_ = $value; + return $msg->($value); +} + +## type predicates ... + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; + + return 1 if $self == $other; + + return unless $self->constraint == $other->constraint; + + if ( $self->has_parent ) { + return unless $other->has_parent; + return unless $self->parent->equals( $other->parent ); + } else { + return if $other->has_parent; + } + + return; +} + +sub is_a_type_of { + my ($self, $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) or return; + + my $current = $self; + + while (my $parent = $current->parent) { + return 1 if $parent->equals($type); + $current = $parent; + } + + return 0; +} + +## compiling the type constraint + +sub compile_type_constraint { + my $self = shift; + $self->_compiled_type_constraint($self->_actually_compile_type_constraint); +} + +## type compilers ... + +sub _actually_compile_type_constraint { + my $self = shift; + + if ( $self->can_be_inlined ) { + return eval_closure( + source => 'sub { ' . $self->_inline_check('$_[0]') . ' }', + environment => $self->inline_environment, + ); + } + + my $check = $self->constraint; + unless ( defined $check ) { + throw_exception( NoConstraintCheckForTypeConstraint => type_name => $self->name ); + } + + return $self->_compile_subtype($check) + if $self->has_parent; + + return $self->_compile_type($check); +} + +sub _compile_subtype { + my ($self, $check) = @_; + + # gather all the parent constraints in order + my @parents; + foreach my $parent ($self->_collect_all_parents) { + push @parents => $parent->constraint; + } + + @parents = grep { $_ != $null_constraint } reverse @parents; + + unless ( @parents ) { + return $self->_compile_type($check); + } else { + # general case, check all the constraints, from the first parent to ourselves + my @checks = @parents; + push @checks, $check if $check != $null_constraint; + return subname($self->name => sub { + my (@args) = @_; + local $_ = $args[0]; + foreach my $check (@checks) { + return undef unless $check->(@args); + } + return 1; + }); + } +} + +sub _compile_type { + my ($self, $check) = @_; + + return $check if $check == $null_constraint; # Item, Any + + return subname($self->name => sub { + my (@args) = @_; + local $_ = $args[0]; + $check->(@args); + }); +} + +## other utils ... + +sub _collect_all_parents { + my $self = shift; + my @parents; + my $current = $self->parent; + while (defined $current) { + push @parents => $current; + $current = $current->parent; + } + return @parents; +} + +sub create_child_type { + my ($self, %opts) = @_; + my $class = ref $self; + return $class->new(%opts, parent => $self); +} + +1; + +# ABSTRACT: The Moose Type Constraint metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents a single type constraint. Moose's built-in type +constraints, as well as constraints you define, are all stored in a +L<Moose::Meta::TypeConstraint::Registry> object as objects of this +class. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint->new(%options) >> + +This creates a new type constraint based on the provided C<%options>: + +=over 8 + +=item * name + +The constraint name. If a name is not provided, it will be set to +"__ANON__". + +=item * parent + +A C<Moose::Meta::TypeConstraint> object which is the parent type for +the type being created. This is optional. + +=item * constraint + +This is the subroutine reference that implements the actual constraint +check. This defaults to a subroutine which always returns true. + +=item * message + +A subroutine reference which is used to generate an error message when +the constraint fails. This is optional. + +=item * coercion + +A L<Moose::Meta::TypeCoercion> object representing the coercions to +the type. This is optional. + +=item * inlined + +A subroutine which returns a string suitable for inlining this type +constraint. It will be called as a method on the type constraint object, and +will receive a single additional parameter, a variable name to be tested +(usually C<"$_"> or C<"$_[0]">. + +This is optional. + +=item * inline_environment + +A hash reference of variables to close over. The keys are variables names, and +the values are I<references> to the variables. + +=back + +=item B<< $constraint->equals($type_name_or_object) >> + +Returns true if the supplied name or type object is the same as the +current type. + +=item B<< $constraint->is_subtype_of($type_name_or_object) >> + +Returns true if the supplied name or type object is a parent of the +current type. + +=item B<< $constraint->is_a_type_of($type_name_or_object) >> + +Returns true if the given type is the same as the current type, or is +a parent of the current type. This is a shortcut for checking +C<equals> and C<is_subtype_of>. + +=item B<< $constraint->coerce($value) >> + +This will attempt to coerce the value to the type. If the type does not +have any defined coercions this will throw an error. + +If no coercion can produce a value matching C<$constraint>, the original +value is returned. + +=item B<< $constraint->assert_coerce($value) >> + +This method behaves just like C<coerce>, but if the result is not valid +according to C<$constraint>, an error is thrown. + +=item B<< $constraint->check($value) >> + +Returns true if the given value passes the constraint for the type. + +=item B<< $constraint->validate($value) >> + +This is similar to C<check>. However, if the type I<is valid> then the +method returns an explicit C<undef>. If the type is not valid, we call +C<< $self->get_message($value) >> internally to generate an error +message. + +=item B<< $constraint->assert_valid($value) >> + +Like C<check> and C<validate>, this method checks whether C<$value> is +valid under the constraint. If it is, it will return true. If it is not, +an exception will be thrown with the results of +C<< $self->get_message($value) >>. + +=item B<< $constraint->name >> + +Returns the type's name, as provided to the constructor. + +=item B<< $constraint->parent >> + +Returns the type's parent, as provided to the constructor, if any. + +=item B<< $constraint->has_parent >> + +Returns true if the type has a parent type. + +=item B<< $constraint->parents >> + +Returns all of the types parents as an list of type constraint objects. + +=item B<< $constraint->constraint >> + +Returns the type's constraint, as provided to the constructor. + +=item B<< $constraint->get_message($value) >> + +This generates a method for the given value. If the type does not have +an explicit message, we generate a default message. + +=item B<< $constraint->has_message >> + +Returns true if the type has a message. + +=item B<< $constraint->message >> + +Returns the type's message as a subroutine reference. + +=item B<< $constraint->coercion >> + +Returns the type's L<Moose::Meta::TypeCoercion> object, if one +exists. + +=item B<< $constraint->has_coercion >> + +Returns true if the type has a coercion. + +=item B<< $constraint->can_be_inlined >> + +Returns true if this type constraint can be inlined. A type constraint which +subtypes an inlinable constraint and does not add an additional constraint +"inherits" its parent type's inlining. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new type constraint of the same class using the +provided C<%options>. The C<parent> option will be the current type. + +This method exists so that subclasses of this class can override this +behavior and change how child types are created. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm new file mode 100644 index 0000000..2f5e5c3 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Class.pm @@ -0,0 +1,265 @@ +package Moose::Meta::TypeConstraint::Class; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Scalar::Util (); +use Moose::Util::TypeConstraints (); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('class' => ( + reader => 'class', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return 'Scalar::Util::blessed(' . $val . ')' + . ' && ' . $val . '->isa(' . B::perlstring($self->class) . ')'; +}; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} + = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my $class_name = $args{class}; + $args{constraint} = sub { $_[0]->isa($class_name) }; + + $args{inlined} = $inliner; + + my $self = $class->SUPER::new( \%args ); + + $self->compile_type_constraint(); + + return $self; +} + +sub parents { + my $self = shift; + return ( + $self->parent, + map { + # FIXME find_type_constraint might find a TC named after the class but that isn't really it + # I did this anyway since it's a convention that preceded TypeConstraint::Class, and it should DWIM + # if anybody thinks this problematic please discuss on IRC. + # a possible fix is to add by attr indexing to the type registry to find types of a certain property + # regardless of their name + Moose::Util::TypeConstraints::find_type_constraint($_) + || + __PACKAGE__->new( class => $_, name => "__ANON__" ) + } Class::MOP::class_of($self->class)->superclasses, + ); +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + if (!defined($other)) { + if (!ref($type_or_name)) { + return $self->class eq $type_or_name; + } + return; + } + + return unless $other->isa(__PACKAGE__); + + return $self->class eq $other->class; +} + +sub is_a_type_of { + my ($self, $type_or_name) = @_; + + ($self->equals($type_or_name) || $self->is_subtype_of($type_or_name)); +} + +sub is_subtype_of { + my ($self, $type_or_name_or_class ) = @_; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class); + + if ( not defined $type ) { + if ( not ref $type_or_name_or_class ) { + # it might be a class + my $class = $self->class; + return 1 if $class ne $type_or_name_or_class + && $class->isa( $type_or_name_or_class ); + } + return; + } + + if ( $type->isa(__PACKAGE__) && $type->class ne $self->class) { + # if $type_or_name_or_class isn't a class, it might be the TC name of another ::Class type + # or it could also just be a type object in this branch + return $self->class->isa( $type->class ); + } else { + # the only other thing we are a subtype of is Object + $self->SUPER::is_subtype_of($type); + } +} + +# This is a bit counter-intuitive, but a child type of a Class type +# constraint is not itself a Class type constraint (it has no class +# attribute). This whole create_child_type thing needs some changing +# though, probably making MMC->new a factory or something. +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +sub get_message { + my $self = shift; + my ($value) = @_; + + if ($self->has_message) { + return $self->SUPER::get_message(@_); + } + + $value = (defined $value ? overload::StrVal($value) : 'undef'); + return "Validation failed for '" . $self->name . "' with value $value (not isa " . $self->class . ")"; +} + +1; + +# ABSTRACT: Class/TypeConstraint parallel hierarchy + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Class - Class/TypeConstraint parallel hierarchy + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints for a class. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Class> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Class->new(%options) >> + +This creates a new class type constraint based on the given +C<%options>. + +It takes the same options as its parent, with two exceptions. First, +it requires an additional option, C<class>, which is name of the +constraint's class. Second, it automatically sets the parent to the +C<Object> type. + +The constructor also overrides the hand optimized type constraint with +one it creates internally. + +=item B<< $constraint->class >> + +Returns the class name associated with the constraint. + +=item B<< $constraint->parents >> + +Returns all the type's parent types, corresponding to its parent +classes. + +=item B<< $constraint->is_subtype_of($type_name_or_object) >> + +If the given type is also a class type, then this checks that the +type's class is a subclass of the other type's class. + +Otherwise it falls back to the implementation in +L<Moose::Meta::TypeConstraint>. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a +C<Moose::Meta::TypeConstraint::Class> object! + +=item B<< $constraint->get_message($value) >> + +This is the same as L<Moose::Meta::TypeConstraint/get_message> except +that it explicitly says C<isa> was checked. This is to help users deal +with accidentally autovivified type constraints. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/DuckType.pm b/lib/Moose/Meta/TypeConstraint/DuckType.pm new file mode 100644 index 0000000..7304f35 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/DuckType.pm @@ -0,0 +1,221 @@ +package Moose::Meta::TypeConstraint::DuckType; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Scalar::Util 'blessed'; +use List::Util 1.33 qw(all); +use Moose::Util 'english_list'; + +use Moose::Util::TypeConstraints (); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('methods' => ( + accessor => 'methods', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return $self->parent->_inline_check($val) + . ' && do {' . "\n" + . 'my $val = ' . $val . ';' . "\n" + . '&List::Util::all(' . "\n" + . 'sub { $val->can($_) },' . "\n" + . join(', ', map { B::perlstring($_) } @{ $self->methods }) + . ');' . "\n" + . '}'; +}; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} + = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my @methods = @{ $args{methods} }; + $args{constraint} = sub { + my $val = $_[0]; + return all { $val->can($_) } @methods; + }; + + $args{inlined} = $inliner; + + my $self = $class->SUPER::new(\%args); + + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + + return $self; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_methods = sort @{ $self->methods }; + my @other_methods = sort @{ $other->methods }; + + return unless @self_methods == @other_methods; + + while ( @self_methods ) { + my $method = shift @self_methods; + my $other_method = shift @other_methods; + + return unless $method eq $other_method; + } + + return 1; +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +sub get_message { + my $self = shift; + my ($value) = @_; + + if ($self->has_message) { + return $self->SUPER::get_message(@_); + } + + return $self->SUPER::get_message($value) unless blessed($value); + + my @methods = grep { !$value->can($_) } @{ $self->methods }; + my $class = blessed $value; + $class ||= $value; + + return $class + . " is missing methods " + . english_list(map { "'$_'" } @methods); +} + +1; + +# ABSTRACT: Type constraint for duck typing + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints based on an enumerated list of +required methods. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::DuckType> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >> + +This creates a new duck type constraint based on the given +C<%options>. + +It takes the same options as its parent, with several +exceptions. First, it requires an additional option, C<methods>. This +should be an array reference containing a list of required method +names. Second, it automatically sets the parent to the C<Object> type. + +Finally, it ignores any provided C<constraint> option. The constraint +is generated automatically based on the provided C<methods>. + +=item B<< $constraint->methods >> + +Returns the array reference of required methods provided to the +constructor. + +=item B<< $constraint->create_child_type >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType> +object! + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Enum.pm b/lib/Moose/Meta/TypeConstraint/Enum.pm new file mode 100644 index 0000000..9e1204d --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Enum.pm @@ -0,0 +1,230 @@ +package Moose::Meta::TypeConstraint::Enum; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Moose::Util::TypeConstraints (); + +use parent 'Moose::Meta::TypeConstraint'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('values' => ( + accessor => 'values', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_inline_var_name' => ( + accessor => '_inline_var_name', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return 'defined(' . $val . ') ' + . '&& !ref(' . $val . ') ' + . '&& $' . $self->_inline_var_name . '{' . $val . '}'; +}; + +my $var_suffix = 0; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str'); + $args{inlined} = $inliner; + + if ( scalar @{ $args{values} } < 1 ) { + throw_exception( MustHaveAtLeastOneValueToEnumerate => params => \%args, + class => $class + ); + } + + for (@{ $args{values} }) { + if (!defined($_)) { + throw_exception( EnumValuesMustBeString => params => \%args, + class => $class, + value => $_ + ); + } + elsif (ref($_)) { + throw_exception( EnumValuesMustBeString => params => \%args, + class => $class, + value => $_ + ); + } + } + + my %values = map { $_ => 1 } @{ $args{values} }; + $args{constraint} = sub { $values{ $_[0] } }; + + my $var_name = 'enums' . $var_suffix++;; + $args{_inline_var_name} = $var_name; + $args{inline_environment} = { '%' . $var_name => \%values }; + + my $self = $class->SUPER::new(\%args); + + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + + return $self; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_values = sort @{ $self->values }; + my @other_values = sort @{ $other->values }; + + return unless @self_values == @other_values; + + while ( @self_values ) { + my $value = shift @self_values; + my $other_value = shift @other_values; + + return unless $value eq $other_value; + } + + return 1; +} + +sub constraint { + my $self = shift; + + my %values = map { $_ => undef } @{ $self->values }; + + return sub { exists $values{$_[0]} }; +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +1; + +# ABSTRACT: Type constraint for enumerated values. + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Enum - Type constraint for enumerated values. + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints based on an enumerated list of +acceptable values. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Enum> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Enum->new(%options) >> + +This creates a new enum type constraint based on the given +C<%options>. + +It takes the same options as its parent, with several +exceptions. First, it requires an additional option, C<values>. This +should be an array reference containing a list of valid string +values. Second, it automatically sets the parent to the C<Str> type. + +Finally, it ignores any provided C<constraint> option. The constraint +is generated automatically based on the provided C<values>. + +=item B<< $constraint->values >> + +Returns the array reference of acceptable values provided to the +constructor. + +=item B<< $constraint->create_child_type >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Enum> +object! + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm new file mode 100644 index 0000000..250e4e6 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -0,0 +1,200 @@ +package Moose::Meta::TypeConstraint::Parameterizable; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use parent 'Moose::Meta::TypeConstraint'; +use Moose::Meta::TypeConstraint::Parameterized; +use Moose::Util::TypeConstraints (); + +use Moose::Util 'throw_exception'; + +use Carp 'confess'; + +__PACKAGE__->meta->add_attribute('constraint_generator' => ( + accessor => 'constraint_generator', + predicate => 'has_constraint_generator', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('inline_generator' => ( + accessor => 'inline_generator', + predicate => 'has_inline_generator', + Class::MOP::_definition_context(), +)); + +sub generate_constraint_for { + my ($self, $type) = @_; + + return unless $self->has_constraint_generator; + + return $self->constraint_generator->($type->type_parameter) + if $type->is_subtype_of($self->name); + + return $self->_can_coerce_constraint_from($type) + if $self->has_coercion + && $self->coercion->has_coercion_for_type($type->parent->name); + + return; +} + +sub _can_coerce_constraint_from { + my ($self, $type) = @_; + my $coercion = $self->coercion; + my $constraint = $self->constraint_generator->($type->type_parameter); + return sub { + local $_ = $coercion->coerce($_); + $constraint->(@_); + }; +} + +sub generate_inline_for { + my ($self, $type, $val) = @_; + + throw_exception( CannotGenerateInlineConstraint => parameterizable_type_object_name => $self->name, + type_name => $type->name, + value => $val, + ) + unless $self->has_inline_generator; + + return '( do { ' . $self->inline_generator->( $self, $type, $val ) . ' } )'; +} + +sub _parse_type_parameter { + my ($self, $type_parameter) = @_; + return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter); +} + +sub parameterize { + my ($self, $type_parameter) = @_; + + my $contained_tc = $self->_parse_type_parameter($type_parameter); + + ## The type parameter should be a subtype of the parent's type parameter + ## if there is one. + + if(my $parent = $self->parent) { + if($parent->can('type_parameter')) { + unless ( $contained_tc->is_a_type_of($parent->type_parameter) ) { + throw_exception( ParameterIsNotSubtypeOfParent => type_parameter => $type_parameter, + type_name => $self->name, + ); + } + } + } + + if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) { + my $tc_name = $self->name . '[' . $contained_tc->name . ']'; + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $tc_name, + parent => $self, + type_parameter => $contained_tc, + parameterized_from => $self, + ); + } + else { + confess("The type parameter must be a Moose meta type"); + } +} + + +1; + +# ABSTRACT: Type constraints which can take a parameter (ArrayRef) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Parameterizable - Type constraints which can take a parameter (ArrayRef) + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents a parameterizable type constraint. This is a +type constraint like C<ArrayRef> or C<HashRef>, that can be +parameterized and made more specific by specifying a contained +type. For example, instead of just an C<ArrayRef> of anything, you can +specify that is an C<ArrayRef[Int]>. + +A parameterizable constraint should not be used as an attribute type +constraint. Instead, when parameterized it creates a +L<Moose::Meta::TypeConstraint::Parameterized> which should be used. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Parameterizable> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +This class is intentionally not documented because the API is +confusing and needs some work. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm new file mode 100644 index 0000000..8db9c88 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm @@ -0,0 +1,188 @@ +package Moose::Meta::TypeConstraint::Parameterized; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterizable; +use Moose::Util 'throw_exception'; + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('type_parameter' => ( + accessor => 'type_parameter', + predicate => 'has_type_parameter', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('parameterized_from' => ( + accessor => 'parameterized_from', + predicate => 'has_parameterized_from', + Class::MOP::_definition_context(), +)); + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + return ( + $self->type_parameter->equals( $other->type_parameter ) + and + $self->parent->equals( $other->parent ) + ); +} + +sub compile_type_constraint { + my $self = shift; + + unless ( $self->has_type_parameter ) { + throw_exception( CannotCreateHigherOrderTypeWithoutATypeParameter => type_name => $self->name ); + } + + my $type_parameter = $self->type_parameter; + + unless ( blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint') ) { + throw_exception( TypeParameterMustBeMooseMetaType => type_name => $self->name ); + } + + foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) { + if (my $constraint = $type->generate_constraint_for($self)) { + $self->_set_constraint($constraint); + return $self->SUPER::compile_type_constraint; + } + } + + # if we get here, then we couldn't + # find a way to parameterize this type + throw_exception( TypeConstraintCannotBeUsedForAParameterizableType => type_name => $self->name, + parent_type_name => $self->parent->name, + ); +} + +sub can_be_inlined { + my $self = shift; + + return + $self->has_parameterized_from + && $self->parameterized_from->has_inline_generator + && $self->type_parameter->can_be_inlined; +} + +sub inline_environment { + my $self = shift; + + return { + ($self->has_parameterized_from + ? (%{ $self->parameterized_from->inline_environment }) + : ()), + ($self->has_type_parameter + ? (%{ $self->type_parameter->inline_environment }) + : ()), + }; +} + +sub _inline_check { + my $self = shift; + + return unless $self->can_be_inlined; + + return $self->parameterized_from->generate_inline_for( $self->type_parameter, @_ ); +} + +sub create_child_type { + my ($self, %opts) = @_; + return Moose::Meta::TypeConstraint::Parameterizable->new(%opts, parent=>$self); +} + +1; + +# ABSTRACT: Type constraints with a bound parameter (ArrayRef[Int]) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Parameterized - Type constraints with a bound parameter (ArrayRef[Int]) + +=head1 VERSION + +version 2.1405 + +=head1 METHODS + +This class is intentionally not documented because the API is +confusing and needs some work. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Parameterized> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Registry.pm b/lib/Moose/Meta/TypeConstraint/Registry.pm new file mode 100644 index 0000000..7c534a7 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Registry.pm @@ -0,0 +1,210 @@ +package Moose::Meta::TypeConstraint::Registry; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Object'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('parent_registry' => ( + reader => 'get_parent_registry', + writer => 'set_parent_registry', + predicate => 'has_parent_registry', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('type_constraints' => ( + reader => 'type_constraints', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub new { + my $class = shift; + my $self = $class->_new(@_); + return $self; +} + +sub has_type_constraint { + my ($self, $type_name) = @_; + ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0 +} + +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) = @_; + + unless ( $type && blessed $type && $type->isa('Moose::Meta::TypeConstraint') ) { + throw_exception( InvalidTypeConstraint => registry_object => $self, + type => $type + ); + } + + $self->type_constraints->{$type->name} = $type; +} + +sub find_type_constraint { + my ($self, $type_name) = @_; + return $self->get_type_constraint($type_name) + if $self->has_type_constraint($type_name); + return $self->get_parent_registry->find_type_constraint($type_name) + if $self->has_parent_registry; + return; +} + +1; + +# ABSTRACT: registry for type constraints + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Registry - registry for type constraints + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a registry that maps type constraint names to +L<Moose::Meta::TypeConstraint> objects. + +Currently, it is only used internally by +L<Moose::Util::TypeConstraints>, which creates a single global +registry. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Registry> is a subclass of +L<Class::MOP::Object>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Registry->new(%options) >> + +This creates a new registry object based on the provided C<%options>: + +=over 8 + +=item * parent_registry + +This is an optional L<Moose::Meta::TypeConstraint::Registry> +object. + +=item * type_constraints + +This is hash reference of type names to type objects. This is +optional. Constraints can be added to the registry after it is +created. + +=back + +=item B<< $registry->get_parent_registry >> + +Returns the registry's parent registry, if it has one. + +=item B<< $registry->has_parent_registry >> + +Returns true if the registry has a parent. + +=item B<< $registry->set_parent_registry($registry) >> + +Sets the parent registry. + +=item B<< $registry->get_type_constraint($type_name) >> + +This returns the L<Moose::Meta::TypeConstraint> object from the +registry for the given name, if one exists. + +=item B<< $registry->has_type_constraint($type_name) >> + +Returns true if the registry has a type of the given name. + +=item B<< $registry->add_type_constraint($type) >> + +Adds a new L<Moose::Meta::TypeConstraint> object to the registry. + +=item B<< $registry->find_type_constraint($type_name) >> + +This method looks in the current registry for the named type. If the +type is not found, then this method will look in the registry's +parent, if it has one. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Role.pm b/lib/Moose/Meta/TypeConstraint/Role.pm new file mode 100644 index 0000000..db609d9 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Role.pm @@ -0,0 +1,239 @@ +package Moose::Meta::TypeConstraint::Role; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Moose::Util::TypeConstraints (); +use Moose::Util (); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('role' => ( + reader => 'role', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return 'Moose::Util::does_role(' + . $val . ', ' + . B::perlstring($self->role) + . ')'; +}; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my $role_name = $args{role}; + $args{constraint} = sub { Moose::Util::does_role( $_[0], $role_name ) }; + + $args{inlined} = $inliner; + + my $self = $class->SUPER::new( \%args ); + + $self->compile_type_constraint(); + + return $self; +} + +sub parents { + my $self = shift; + return ( + $self->parent, + map { + # FIXME find_type_constraint might find a TC named after the role but that isn't really it + # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM + # if anybody thinks this problematic please discuss on IRC. + # a possible fix is to add by attr indexing to the type registry to find types of a certain property + # regardless of their name + Moose::Util::TypeConstraints::find_type_constraint($_) + || + __PACKAGE__->new( role => $_, name => "__ANON__" ) + } @{ Class::MOP::class_of($self->role)->get_roles }, + ); +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless defined $other; + return unless $other->isa(__PACKAGE__); + + return $self->role eq $other->role; +} + +sub is_a_type_of { + my ($self, $type_or_name) = @_; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + ($self->equals($type) || $self->is_subtype_of($type_or_name)); +} + +sub is_subtype_of { + my ($self, $type_or_name_or_role ) = @_; + + if ( not ref $type_or_name_or_role ) { + # it might be a role + my $class = Class::MOP::class_of($self->role); + return 1 if defined($class) && $class->does_role( $type_or_name_or_role ); + } + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role); + + return unless defined $type; + + if ( $type->isa(__PACKAGE__) ) { + # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type + # or it could also just be a type object in this branch + my $class = Class::MOP::class_of($self->role); + return defined($class) && $class->does_role( $type->role ); + } else { + # the only other thing we are a subtype of is Object + $self->SUPER::is_subtype_of($type); + } +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +1; + +# ABSTRACT: Role/TypeConstraint parallel hierarchy + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints for a role. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Role> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Role->new(%options) >> + +This creates a new role type constraint based on the given +C<%options>. + +It takes the same options as its parent, with two exceptions. First, +it requires an additional option, C<role>, which is name of the +constraint's role. Second, it automatically sets the parent to the +C<Object> type. + +The constructor also overrides the hand optimized type constraint with +one it creates internally. + +=item B<< $constraint->role >> + +Returns the role name associated with the constraint. + +=item B<< $constraint->parents >> + +Returns all the type's parent types, corresponding to the roles that +its role does. + +=item B<< $constraint->is_subtype_of($type_name_or_object) >> + +If the given type is also a role type, then this checks that the +type's role does the other type's role. + +Otherwise it falls back to the implementation in +L<Moose::Meta::TypeConstraint>. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Role> +object! + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm new file mode 100644 index 0000000..da85f86 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Union.pm @@ -0,0 +1,348 @@ +package Moose::Meta::TypeConstraint::Union; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Moose::Meta::TypeCoercion::Union; + +use List::Util 1.33 qw(first all); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('type_constraints' => ( + accessor => 'type_constraints', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +sub new { + my ($class, %options) = @_; + + my $name = join '|' => sort { $a cmp $b } + map { $_->name } @{ $options{type_constraints} }; + + my $self = $class->SUPER::new( + name => $name, + %options, + ); + + $self->_set_constraint( $self->_compiled_type_constraint ); + + return $self; +} + +# XXX - this is a rather gross implementation of laziness for the benefit of +# MX::Types. If we try to call ->has_coercion on the objects during object +# construction, this does not work when defining a recursive constraint with +# MX::Types. +sub coercion { + my $self = shift; + + return $self->{coercion} if exists $self->{coercion}; + + # Using any instead of grep here causes a weird error with some corner + # cases when MX::Types is in use. See RT #61001. + if ( grep { $_->has_coercion } @{ $self->type_constraints } ) { + return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self ); + } + else { + return $self->{coercion} = undef; + } +} + +sub has_coercion { + return defined $_[0]->coercion; +} + +sub _actually_compile_type_constraint { + my $self = shift; + + my @constraints = @{ $self->type_constraints }; + + return sub { + my $value = shift; + foreach my $type (@constraints) { + return 1 if $type->check($value); + } + return undef; + }; +} + +sub can_be_inlined { + my $self = shift; + + # This was originally done with all() from List::MoreUtils, but that + # caused some sort of bizarro parsing failure under 5.10. + for my $tc ( @{ $self->type_constraints } ) { + return 0 unless $tc->can_be_inlined; + } + + return 1; +} + +sub _inline_check { + my $self = shift; + my $val = shift; + + return '(' + . ( + join ' || ', map { '(' . $_->_inline_check($val) . ')' } + @{ $self->type_constraints } + ) + . ')'; +} + +sub inline_environment { + my $self = shift; + + return { map { %{ $_->inline_environment } } + @{ $self->type_constraints } }; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_constraints = @{ $self->type_constraints }; + my @other_constraints = @{ $other->type_constraints }; + + return unless @self_constraints == @other_constraints; + + # FIXME presort type constraints for efficiency? + constraint: foreach my $constraint ( @self_constraints ) { + for ( my $i = 0; $i < @other_constraints; $i++ ) { + if ( $constraint->equals($other_constraints[$i]) ) { + splice @other_constraints, $i, 1; + next constraint; + } + } + } + + return @other_constraints == 0; +} + +sub parent { + my $self = shift; + + my ($first, @rest) = @{ $self->type_constraints }; + + for my $parent ( $first->_collect_all_parents ) { + return $parent if all { $_->is_a_type_of($parent) } @rest; + } + + return; +} + +sub validate { + my ($self, $value) = @_; + my $message; + foreach my $type (@{$self->type_constraints}) { + my $err = $type->validate($value); + return unless defined $err; + $message .= ($message ? ' and ' : '') . $err + if defined $err; + } + return ($message . ' in (' . $self->name . ')') ; +} + +sub find_type_for { + my ($self, $value) = @_; + + return first { $_->check($value) } @{ $self->type_constraints }; +} + +sub is_a_type_of { + my ($self, $type_name) = @_; + + return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints }; +} + +sub is_subtype_of { + my ($self, $type_name) = @_; + + return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints }; +} + +sub create_child_type { + my ( $self, %opts ) = @_; + + my $constraint + = Moose::Meta::TypeConstraint->new( %opts, parent => $self ); + + # if we have a type constraint union, and no + # type check, this means we are just aliasing + # the union constraint, which means we need to + # handle this differently. + # - SL + if ( not( defined $opts{constraint} ) + && $self->has_coercion ) { + $constraint->coercion( + Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self, + ) + ); + } + + return $constraint; +} + +1; + +# ABSTRACT: A union of Moose type constraints + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Union - A union of Moose type constraints + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This metaclass represents a union of type constraints. A union takes +multiple type constraints, and is true if any one of its member +constraints is true. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Union> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Union->new(%options) >> + +This creates a new class type constraint based on the given +C<%options>. + +It takes the same options as its parent. It also requires an +additional option, C<type_constraints>. This is an array reference +containing the L<Moose::Meta::TypeConstraint> objects that are the +members of the union type. The C<name> option defaults to the names +all of these member types sorted and then joined by a pipe (|). + +The constructor sets the implementation of the constraint so that is +simply calls C<check> on the newly created object. + +Finally, the constructor also makes sure that the object's C<coercion> +attribute is a L<Moose::Meta::TypeCoercion::Union> object. + +=item B<< $constraint->type_constraints >> + +This returns the array reference of C<type_constraints> provided to +the constructor. + +=item B<< $constraint->parent >> + +This returns the nearest common ancestor of all the components of the union. + +=item B<< $constraint->check($value) >> + +=item B<< $constraint->validate($value) >> + +These two methods simply call the relevant method on each of the +member type constraints in the union. If any type accepts the value, +the value is valid. + +With C<validate> the error message returned includes all of the error +messages returned by the member type constraints. + +=item B<< $constraint->equals($type_name_or_object) >> + +A type is considered equal if it is also a union type, and the two +unions have the same member types. + +=item B<< $constraint->find_type_for($value) >> + +This returns the first member type constraint for which C<check($value)> is +true, allowing you to determine which of the Union's member type constraints +a given value matches. + +=item B<< $constraint->is_a_type_of($type_name_or_object) >> + +This returns true if all of the member type constraints return true +for the C<is_a_type_of> method. + +=item B<< $constraint->is_subtype_of >> + +This returns true if all of the member type constraints return true +for the C<is_a_subtype_of> method. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm new file mode 100644 index 0000000..63b5c56 --- /dev/null +++ b/lib/Moose/Object.pm @@ -0,0 +1,272 @@ +package Moose::Object; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Carp (); +use Devel::GlobalDestruction (); +use MRO::Compat (); +use Scalar::Util (); +use Try::Tiny (); + +use Moose::Util (); + +use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class'; +use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class'; + +sub new { + my $class = shift; + my $real_class = Scalar::Util::blessed($class) || $class; + + my $params = $real_class->BUILDARGS(@_); + + return Class::MOP::Class->initialize($real_class)->new_object($params); +} + +sub BUILDARGS { + my $class = shift; + if ( scalar @_ == 1 ) { + unless ( defined $_[0] && ref $_[0] eq 'HASH' ) { + Moose::Util::throw_exception( "SingleParamsToNewMustBeHashRef" ); + } + return { %{ $_[0] } }; + } + elsif ( @_ % 2 ) { + Carp::carp( + "The new() method for $class expects a hash reference or a key/value list." + . " You passed an odd number of arguments" ); + return { @_, undef }; + } + else { + return {@_}; + } +} + +sub BUILDALL { + # NOTE: we ask Perl if we even + # need to do this first, to avoid + # extra meta level calls + return unless $_[0]->can('BUILD'); + my ($self, $params) = @_; + foreach my $method (reverse Class::MOP::class_of($self)->find_all_methods_by_name('BUILD')) { + $method->{code}->execute($self, $params); + } +} + +sub DEMOLISHALL { + my $self = shift; + my ($in_global_destruction) = @_; + + # NOTE: we ask Perl if we even + # need to do this first, to avoid + # extra meta level calls + return unless $self->can('DEMOLISH'); + + my @isa; + if ( my $meta = Class::MOP::class_of($self ) ) { + @isa = $meta->linearized_isa; + } else { + # We cannot count on being able to retrieve a previously made + # metaclass, _or_ being able to make a new one during global + # destruction. However, we should still be able to use mro at + # that time (at least tests suggest so ;) + my $class_name = ref $self; + @isa = @{ mro::get_linear_isa($class_name) } + } + + foreach my $class (@isa) { + no strict 'refs'; + my $demolish = *{"${class}::DEMOLISH"}{CODE}; + $self->$demolish($in_global_destruction) + if defined $demolish; + } +} + +sub DESTROY { + my $self = shift; + + local $?; + + # < doy> if the destructor is being called because an exception is thrown, then $@ will be set + # < doy> but if DEMOLISH does an eval which succeeds, that will clear $@ + # < doy> which is broken + # < doy> try::tiny implicitly localizes $@ in the try block, which fixes that + Try::Tiny::try { + $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction); + } + Try::Tiny::catch { + die $_; + }; + + return; +} + +# 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 appropriate see Moose::Meta::Role +sub does { + my ($self, $role_name) = @_; + my $class = Scalar::Util::blessed($self) || $self; + my $meta = Class::MOP::Class->initialize($class); + (defined $role_name) + || Moose::Util::throw_exception( DoesRequiresRoleName => class_name => $meta->name ); + return 1 if $meta->can('does_role') && $meta->does_role($role_name); + return 0; +} + +sub dump { + my $self = shift; + require Data::Dumper; + local $Data::Dumper::Maxdepth = shift if @_; + Data::Dumper::Dumper $self; +} + +1; + +# ABSTRACT: The base object for Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Object - The base object for Moose + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is the default base class for all Moose-using classes. When +you C<use Moose> in this class, your class will inherit from this +class. + +It provides a default constructor and destructor, which run all of the +C<BUILD> and C<DEMOLISH> methods in the inheritance hierarchy, +respectively. + +You don't actually I<need> to inherit from this in order to use Moose, +but it makes it easier to take advantage of all of Moose's features. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Object->new(%params|$params) >> + +This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new +instance of the appropriate class. Once the instance is created, it +calls C<< $instance->BUILD($params) >> for each C<BUILD> method in the +inheritance hierarchy. + +=item B<< Moose::Object->BUILDARGS(%params|$params) >> + +The default implementation of this method accepts a hash or hash +reference of named parameters. If it receives a single argument that +I<isn't> a hash reference it throws an error. + +You can override this method in your class to handle other types of +options passed to the constructor. + +This method should always return a hash reference of named options. + +=item B<< $object->does($role_name) >> + +This returns true if the object does the given role. + +=item B<< $object->DOES($class_or_role_name) >> + +This is a Moose role-aware implementation of L<UNIVERSAL/DOES>. + +This is effectively the same as writing: + + $object->does($name) || $object->isa($name) + +This method will work with Perl 5.8, which did not implement +C<UNIVERSAL::DOES>. + +=item B<< $object->dump($maxdepth) >> + +This is a handy utility for C<Data::Dumper>ing an object. By default, +the maximum depth is 1, to avoid making a mess. + +=item B<< $object->DESTROY >> + +A default destructor is provided, which calls +C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH> +method in the inheritance hierarchy. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm new file mode 100644 index 0000000..72c9bd6 --- /dev/null +++ b/lib/Moose/Role.pm @@ -0,0 +1,381 @@ +use strict; +use warnings; +package Moose::Role; +our $VERSION = '2.1405'; + +use Scalar::Util (); +use Carp (); +use Class::Load 'is_class_loaded'; +use Module::Runtime 'module_notional_filename'; + +use Sub::Exporter; + +use Moose (); +use Moose::Util 'throw_exception'; + +use Moose::Exporter; +use Moose::Meta::Role; +use Moose::Util::TypeConstraints; + +sub extends { + throw_exception("RolesDoNotSupportExtends"); +} + +sub with { + Moose::Util::apply_all_roles( shift, @_ ); +} + +sub requires { + my $meta = shift; + throw_exception( MustSpecifyAtleastOneMethod => role_name => $meta->name ) unless @_; + $meta->add_required_methods(@_); +} + +sub excludes { + my $meta = shift; + throw_exception( MustSpecifyAtleastOneRole => role_name => $meta->name ) unless @_; + $meta->add_excluded_roles(@_); +} + +sub has { + my $meta = shift; + my $name = shift; + throw_exception( InvalidHasProvidedInARole => role_name => $meta->name, + attribute_name => $name, + ) + if @_ == 1; + my %context = Moose::Util::_caller_info; + $context{context} = 'has declaration'; + $context{type} = 'role'; + my %options = ( definition_context => \%context, @_ ); + my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ]; + $meta->add_attribute( $_, %options ) for @$attrs; +} + +sub _add_method_modifier { + my $type = shift; + my $meta = shift; + + if ( ref($_[0]) eq 'Regexp' ) { + throw_exception( RolesDoNotSupportRegexReferencesForMethodModifiers => modifier_type => $type, + role_name => $meta->name, + ); + } + + Moose::Util::add_method_modifier($meta, $type, \@_); +} + +sub before { _add_method_modifier('before', @_) } + +sub after { _add_method_modifier('after', @_) } + +sub around { _add_method_modifier('around', @_) } + +# see Moose.pm for discussion +sub super { + return unless $Moose::SUPER_BODY; + $Moose::SUPER_BODY->(@Moose::SUPER_ARGS); +} + +sub override { + my $meta = shift; + my ( $name, $code ) = @_; + $meta->add_override_method_modifier( $name, $code ); +} + +sub inner { + throw_exception("RolesDoNotSupportInner"); +} + +sub augment { + throw_exception("RolesDoNotSupportAugment"); +} + +Moose::Exporter->setup_import_methods( + with_meta => [ + qw( with requires excludes has before after around override ) + ], + as_is => [ + qw( extends super inner augment ), + 'Carp::confess', + 'Scalar::Util::blessed', + ], +); + +sub init_meta { + shift; + my %args = @_; + + my $role = $args{for_class}; + + unless ($role) { + require Moose; + throw_exception( InitMetaRequiresClass => params => \%args ); + } + + my $metaclass = $args{metaclass} || "Moose::Meta::Role"; + my $meta_name = exists $args{meta_name} ? $args{meta_name} : 'meta'; + + throw_exception( MetaclassNotLoaded => class_name => $metaclass ) + unless is_class_loaded($metaclass); + + throw_exception( MetaclassMustBeASubclassOfMooseMetaRole => role_name => $metaclass ) + unless $metaclass->isa('Moose::Meta::Role'); + + # make a subtype for each Moose role + role_type $role unless find_type_constraint($role); + + my $meta; + if ( $meta = Class::MOP::get_metaclass_by_name($role) ) { + unless ( $meta->isa("Moose::Meta::Role") ) { + if ( $meta->isa('Moose::Meta::Class') ) { + throw_exception( MetaclassIsAClassNotASubclassOfGivenMetaclass => class_name => $role, + metaclass => $metaclass, + ); + } else { + throw_exception( MetaclassIsNotASubclassOfGivenMetaclass => class_name => $role, + metaclass => $metaclass, + ); + } + } + } + else { + $meta = $metaclass->initialize($role); + my $filename = module_notional_filename($meta->name); + $INC{$filename} = '(set by Moose)' + unless exists $INC{$filename}; + } + + if (defined $meta_name) { + # also check for inherited non moose 'meta' method? + my $existing = $meta->get_method($meta_name); + if ($existing && !$existing->isa('Class::MOP::Method::Meta')) { + Carp::cluck "Moose::Role is overwriting an existing method named " + . "$meta_name in role $role with a method " + . "which returns the class's metaclass. If this is " + . "actually what you want, you should remove the " + . "existing method, otherwise, you should rename or " + . "disable this generated method using the " + . "'-meta_name' option to 'use Moose::Role'."; + } + $meta->_add_meta_method($meta_name); + } + + return $meta; +} + +1; + +# ABSTRACT: The Moose Role + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Role - The Moose Role + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Eq; + use Moose::Role; # automatically turns on strict and warnings + + requires 'equal'; + + sub no_equal { + my ($self, $other) = @_; + !$self->equal($other); + } + + # ... then in your classes + + package Currency; + use Moose; # automatically turns on strict and warnings + + with 'Eq'; + + sub equal { + my ($self, $other) = @_; + $self->as_float == $other->as_float; + } + + # ... and also + + package Comparator; + use Moose; + + has compare_to => ( + is => 'ro', + does => 'Eq', + handles => 'Eq', + ); + + # ... which allows + + my $currency1 = Currency->new(...); + my $currency2 = Currency->new(...); + Comparator->new(compare_to => $currency1)->equal($currency2); + +=head1 DESCRIPTION + +The concept of roles is documented in L<Moose::Manual::Roles>. This document +serves as API documentation. + +=head1 EXPORTED FUNCTIONS + +Moose::Role currently supports all of the functions that L<Moose> exports, but +differs slightly in how some items are handled (see L</CAVEATS> below for +details). + +Moose::Role also offers two role-specific keyword exports: + +=over 4 + +=item B<requires (@method_names)> + +Roles can require that certain methods are implemented by any class which +C<does> the role. + +Note that attribute accessors also count as methods for the purposes +of satisfying the requirements of a role. + +=item B<excludes (@role_names)> + +Roles can C<exclude> other roles, in effect saying "I can never be combined +with these C<@role_names>". This is a feature which should not be used +lightly. + +=back + +=head2 B<unimport> + +Moose::Role offers a way to remove the keywords it exports, through the +C<unimport> method. You simply have to say C<no Moose::Role> at the bottom of +your code for this to work. + +=head1 METACLASS + +When you use Moose::Role, you can specify traits which will be applied to your +role metaclass: + + use Moose::Role -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<Moose/Metaclass and Trait Name Resolution> for more +details. + +All role metaclasses (note, not the role itself) extend L<Moose::Meta::Role>. +You can test if a package is a role or not using L<Moose::Util/is_role>. + +=head1 APPLYING ROLES + +In addition to being applied to a class using the 'with' syntax (see +L<Moose::Manual::Roles>) and using the L<Moose::Util> 'apply_all_roles' +method, roles may also be applied to an instance of a class using +L<Moose::Util> 'apply_all_roles' or the role's metaclass: + + MyApp::Test::SomeRole->meta->apply( $instance ); + +Doing this creates a new, mutable, anonymous subclass, applies the role to that, +and reblesses. In a debugger, for example, you will see class names of the +form C< Moose::Meta::Class::__ANON__::SERIAL::6 >, which means that doing a +'ref' on your instance may not return what you expect. See L<Moose::Object> for +'DOES'. + +Additional params may be added to the new instance by providing +'rebless_params'. See L<Moose::Meta::Role::Application::ToInstance>. + +=head1 CAVEATS + +Role support has only a few caveats: + +=over 4 + +=item * + +Roles cannot use the C<extends> keyword; it will throw an exception for now. +The same is true of the C<augment> and C<inner> keywords (not sure those +really make sense for roles). All other Moose keywords will be I<deferred> +so that they can be applied to the consuming class. + +=item * + +Role composition does its best to B<not> be order-sensitive when it comes to +conflict resolution and requirements detection. However, it is order-sensitive +when it comes to method modifiers. All before/around/after modifiers are +included whenever a role is composed into a class, and then applied in the order +in which the roles are used. This also means that there is no conflict for +before/around/after modifiers. + +In most cases, this will be a non-issue; however, it is something to keep in +mind when using method modifiers in a role. You should never assume any +ordering. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Spec/Role.pod b/lib/Moose/Spec/Role.pod new file mode 100644 index 0000000..f7b288d --- /dev/null +++ b/lib/Moose/Spec/Role.pod @@ -0,0 +1,397 @@ +# PODNAME: Moose::Spec::Role +# ABSTRACT: Formal spec for Role behavior + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Spec::Role - Formal spec for Role behavior + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +B<NOTE:> This document is currently incomplete. + +=head2 Components of a Role + +=over 4 + +=item Excluded Roles + +A role can have a list of excluded roles, these are basically +roles that they shouldn't be composed with. This is not just +direct composition either, but also "inherited" composition. + +This feature was taken from the Fortress language and is really +of most use when building a large set of role "building blocks" +some of which should never be used together. + +=item Attributes + +A roles attributes are similar to those of a class, except that +they are not actually applied. This means that methods that are +generated by an attributes accessor will not be generated in the +role, but only created once the role is applied to a class. + +=item Methods + +These are the methods defined within the role. Simple as that. + +=item Required Methods + +A role can require a consuming class (or role) to provide a +given method. Failure to do so for classes is a fatal error, +while for roles it simply passes on the method requirement to +the consuming role. + +=item Required Attributes + +Just as a role can require methods, it can also require attributes. +The requirement fulfilling attribute must implement at least as much +as is required. That means, for instance, that if the role requires +that the attribute be read-only, then it must at least have a reader +and can also have a writer. It means that if the role requires that +the attribute be an ArrayRef, then it must either be an ArrayRef or +a subtype of an ArrayRef. + +=item Overridden Methods + +The C<override> and C<super> keywords are allowed in roles, but +their behavior is different from that of its class counterparts. +The C<super> in a class refers directly to that class's superclass, +while the C<super> in a role is deferred and only has meaning once +the role is composed into a class. Once that composition occurs, +C<super> then refers to that class's superclass. + +It is key to remember that roles do not have hierarchy, so they +can never have a I<super> role. + +=item Method Modifiers + +These are the C<before>, C<around> and C<after> modifiers provided +in Moose classes. The difference here is that the modifiers are not +actually applied until the role is composed into a class (this is +just like attributes and the C<override> keyword). + +=back + +=head2 Role Composition + +=head3 Composing into a Class + +=over 4 + +=item Excluded Roles + +=item Required Methods + +=item Required Attributes + +=item Attributes + +=item Methods + +=item Overridden methods + +=item Method Modifiers (before, around, after) + +=back + +=head3 Composing into a Instance + +=head3 Composing into a Role + +=over 4 + +=item Excluded Roles + +=item Required Methods + +=item Required Attributes + +=item Attributes + +=item Methods + +=item Overridden methods + +=item Method Modifiers (before, around, after) + +=back + +=head3 Role Summation + +When multiple roles are added to another role (using the +C<with @roles> keyword) the roles are composed symmetrically. +The product of the composition is a composite role +(L<Moose::Meta::Role::Composite>). + +=over 4 + +=item Excluded Roles + +=item Required Methods + +=item Required Attributes + +=item Attributes + +Attributes with the same name will conflict and are considered +a unrecoverable error. No other aspect of the attribute is +examined, it is enough that just the attribute names conflict. + +The reason for such early and harsh conflicts with attributes +is because there is so much room for variance between two +attributes that the problem quickly explodes and rules get +very complex. It is my opinion that this complexity is not +worth the trouble. + +=item Methods + +Methods with the same name will conflict, but no error is +thrown, instead the method name is added to the list of +I<required> methods for the new composite role. + +To look at this in terms of set theory, each role can be +said to have a set of methods. The symmetric difference of +these two sets is the new set of methods for the composite +role, while the intersection of these two sets are the +conflicts. This can be illustrated like so: + + Role A has method set { a, b, c } + Role B has method set { c, d, e } + + The composite role (A,B) has + method set { a, b, d, e } + conflict set { c } + +=item Overridden methods + +An overridden method can conflict in one of two ways. + +The first way is with another overridden method of the same +name, and this is considered an unrecoverable error. This +is an obvious error since you cannot override a method twice +in the same class. + +The second way for conflict is for an overridden method and a +regular method to have the same name. This is also an unrecoverable +error since there is no way to combine these two, nor is it +okay for both items to be composed into a single class at some +point. + +The use of override in roles can be tricky, but if used +carefully they can be a very powerful tool. + +=item Method Modifiers (before, around, after) + +Method modifiers are the only place where the ordering of +role composition matters. This is due to the nature of +method modifiers themselves. + +Since a method can have multiple method modifiers, these +are just collected in order to be later applied to the +class in that same order. + +In general, great care should be taken in using method +modifiers in roles. The order sensitivity can possibly +lead to subtle and difficult to find bugs if they are +overused. As with all good things in life, moderation +is the key. + +=back + +=head3 Composition Edge Cases + +This is a just a set of complex edge cases which can easily get +confused. This attempts to clarify those cases and provide an +explanation of what is going on in them. + +=over 4 + +=item Role Method Overriding + +Many people want to "override" methods in roles they are consuming. +This works fine for classes, since the local class method is favored +over the role method. However in roles it is trickier, this is because +conflicts result in neither method being chosen and the method being +"required" instead. + +Here is an example of this (incorrect) type of overriding. + + package Role::Foo; + use Moose::Role; + + sub foo { ... } + + package Role::FooBar; + use Moose::Role; + + with 'Role::Foo'; + + sub foo { ... } + sub bar { ... } + +Here the C<foo> methods conflict and the Role::FooBar now requires a +class or role consuming it to implement C<foo>. This is very often not +what the user wants. + +Now here is an example of the (correct) type of overriding, only it is +not overriding at all, as is explained in the text below. + + package Role::Foo; + use Moose::Role; + + sub foo { ... } + + package Role::Bar; + use Moose::Role; + + sub foo { ... } + sub bar { ... } + + package Role::FooBar; + use Moose::Role; + + with 'Role::Foo', 'Role::Bar'; + + sub foo { ... } + +This works because the combination of Role::Foo and Role::Bar produce +a conflict with the C<foo> method. This conflict results in the +composite role (that was created by the combination of Role::Foo +and Role::Bar using the I<with> keyword) having a method requirement +of C<foo>. The Role::FooBar then fulfills this requirement. + +It is important to note that Role::FooBar is simply fulfilling the +required C<foo> method, and **NOT** overriding C<foo>. This is an +important distinction to make. + +Now here is another example of a (correct) type of overriding, this +time using the I<excludes> option. + + package Role::Foo; + use Moose::Role; + + sub foo { ... } + + package Role::FooBar; + use Moose::Role; + + with 'Role::Foo' => { -excludes => 'foo' }; + + sub foo { ... } + sub bar { ... } + +By specifically excluding the C<foo> method during composition, +we allow B<Role::FooBar> to define its own version of C<foo>. + +=back + +=head1 SEE ALSO + +=over 4 + +=item Traits + +Roles are based on Traits, which originated in the Smalltalk +community. + +=over 4 + +=item L<http://www.iam.unibe.ch/~scg/Research/Traits/> + +This is the main site for the original Traits papers. + +=item L<Class::Trait> + +I created this implementation of traits several years ago, +after reading the papers linked above. (This module is now +maintained by Ovid and I am no longer involved with it). + +=back + +=item Roles + +Since they are relatively new, and the Moose implementation +is probably the most mature out there, roles don't have much +to link to. However, here is some bits worth looking at (mostly +related to Perl 6) + +=over 4 + +=item L<http://www.oreillynet.com/onlamp/blog/2006/08/roles_composable_units_of_obje.html> + +This is chromatic's take on roles, which is worth reading since +he was/is one of the big proponents of them. + +=item L<http://svn.perl.org/perl6/doc/trunk/design/syn/S12.pod> + +This is Synopsis 12, which is all about the Perl 6 Object System. +Which, of course, includes roles. + +=back + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Unsweetened.pod b/lib/Moose/Unsweetened.pod new file mode 100644 index 0000000..11d2e43 --- /dev/null +++ b/lib/Moose/Unsweetened.pod @@ -0,0 +1,77 @@ +# PODNAME: Moose::Unsweetened +# ABSTRACT: Moved to Moose::Manual::Unsweetened, so go read that + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Unsweetened - Moved to Moose::Manual::Unsweetened, so go read that + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This document has been moved to L<Moose::Manual::Unsweetened>. This +POD document still exists for the benefit of anyone out there who +might've linked to it in the past. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm new file mode 100644 index 0000000..18eb8e1 --- /dev/null +++ b/lib/Moose/Util.pm @@ -0,0 +1,734 @@ +package Moose::Util; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Module::Runtime 0.014 'use_package_optimistically', 'use_module', 'module_notional_filename'; +use Data::OptList; +use Params::Util qw( _STRING ); +use Sub::Exporter; +use Scalar::Util 'blessed'; +use List::Util 1.33 qw(first any all); +use overload (); +use Try::Tiny; + + +my @exports = qw[ + find_meta + is_role + does_role + search_class_by_role + ensure_all_roles + apply_all_roles + with_traits + get_all_init_args + get_all_attribute_values + resolve_metatrait_alias + resolve_metaclass_alias + add_method_modifier + english_list + meta_attribute_alias + meta_class_alias + throw_exception +]; + +Sub::Exporter::setup_exporter({ + exports => \@exports, + groups => { all => \@exports } +}); + +# Things that need to ->import from Moose::Util +# should be loaded after Moose::Util defines ->import +require Class::MOP; + +sub throw_exception { + my ($class_name, @args_to_exception) = @_; + my $class = "Moose::Exception::$class_name"; + _load_user_class( $class ); + die $class->new( @args_to_exception ); +} + +## some utils for the utils ... + +sub find_meta { Class::MOP::class_of(@_) } + +## the functions ... + +sub is_role { + my $package_or_obj = shift; + + my $meta = find_meta($package_or_obj); + return if not $meta; + return $meta->isa('Moose::Meta::Role'); +} + +sub does_role { + my ($class_or_obj, $role) = @_; + + if (try { $class_or_obj->isa('Moose::Object') }) { + return $class_or_obj->does($role); + } + + my $meta = find_meta($class_or_obj); + + return unless defined $meta; + return unless $meta->can('does_role'); + return 1 if $meta->does_role($role); + return; +} + +sub search_class_by_role { + my ($class_or_obj, $role) = @_; + + my $meta = find_meta($class_or_obj); + + return unless defined $meta; + + my $role_name = blessed $role ? $role->name : $role; + + foreach my $class ($meta->class_precedence_list) { + + my $_meta = find_meta($class); + + next unless defined $_meta; + + foreach my $role (@{ $_meta->roles || [] }) { + return $class if $role->name eq $role_name; + } + } + + return; +} + +# this can possibly behave in unexpected ways because the roles being composed +# before being applied could differ from call to call; I'm not sure if or how +# to document this possible quirk. +sub ensure_all_roles { + my $applicant = shift; + _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); +} + +sub apply_all_roles { + my $applicant = shift; + _apply_all_roles($applicant, undef, @_); +} + +sub _apply_all_roles { + my $applicant = shift; + my $role_filter = shift; + + unless (@_) { + require Moose; + throw_exception( MustSpecifyAtleastOneRoleToApplicant => applicant => $applicant ); + } + + # If @_ contains role meta objects, mkopt will think that they're values, + # because they're references. In other words (roleobj1, roleobj2, + # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ] + # -- this is no good. We'll preprocess @_ first to eliminate the potential + # bug. + # -- rjbs, 2011-04-08 + my $roles = Data::OptList::mkopt( [@_], { + moniker => 'role', + name_test => sub { + ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role') + } + }); + + my @role_metas; + foreach my $role (@$roles) { + my $meta; + + if ( blessed $role->[0] ) { + $meta = $role->[0]; + } + else { + &use_module($role->[0], $role->[1] && $role->[1]{-version} ? $role->[1]{-version} : ()); + $meta = find_meta( $role->[0] ); + } + + unless ($meta && $meta->isa('Moose::Meta::Role') ) { + throw_exception( CanOnlyConsumeRole => role_name => $role->[0] ); + } + + push @role_metas, [ $meta, $role->[1] ]; + } + + if ( defined $role_filter ) { + @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; + } + + return unless @role_metas; + + _load_user_class($applicant) + unless blessed($applicant) + || Class::MOP::class_of($applicant); + + my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) ); + + if ( scalar @role_metas == 1 ) { + my ( $role, $params ) = @{ $role_metas[0] }; + $role->apply( $meta, ( defined $params ? %$params : () ) ); + } + else { + Moose::Meta::Role->combine(@role_metas)->apply($meta); + } +} + +sub with_traits { + my ($class, @roles) = @_; + return $class unless @roles; + return Moose::Meta::Class->create_anon_class( + superclasses => [$class], + roles => \@roles, + cache => 1, + )->name; +} + +# instance deconstruction ... + +sub get_all_attribute_values { + my ($class, $instance) = @_; + return +{ + map { $_->name => $_->get_value($instance) } + grep { $_->has_value($instance) } + $class->get_all_attributes + }; +} + +sub get_all_init_args { + my ($class, $instance) = @_; + return +{ + map { $_->init_arg => $_->get_value($instance) } + grep { $_->has_value($instance) } + grep { defined($_->init_arg) } + $class->get_all_attributes + }; +} + +sub resolve_metatrait_alias { + return resolve_metaclass_alias( @_, trait => 1 ); +} + +sub _build_alias_package_name { + my ($type, $name, $trait) = @_; + return 'Moose::Meta::' + . $type + . '::Custom::' + . ( $trait ? 'Trait::' : '' ) + . $name; +} + +{ + my %cache; + + sub resolve_metaclass_alias { + my ( $type, $metaclass_name, %options ) = @_; + + my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); + return $cache{$cache_key}{$metaclass_name} + if $cache{$cache_key}{$metaclass_name}; + + my $possible_full_name = _build_alias_package_name( + $type, $metaclass_name, $options{trait} + ); + + my @possible = ($possible_full_name, $metaclass_name); + for my $package (@possible) { + use_package_optimistically($package); + if ($package->can('register_implementation')) { + return $cache{$cache_key}{$metaclass_name} = + $package->register_implementation; + } + elsif (find_meta($package)) { + return $cache{$cache_key}{$metaclass_name} = $package; + } + } + + throw_exception( CannotLocatePackageInINC => possible_packages => _english_list_or(@possible), + INC => \@INC, + type => $type, + metaclass_name => $metaclass_name, + params => \%options + ); + } +} + +sub add_method_modifier { + my ( $class_or_obj, $modifier_name, $args ) = @_; + my $meta + = $class_or_obj->can('add_before_method_modifier') + ? $class_or_obj + : find_meta($class_or_obj); + my $code = pop @{$args}; + 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->get_all_methods; + my @matched_methods + = grep { $_->name =~ @{$args}[0] } @all_methods; + $meta->$add_modifier_method( $_->name, $code ) + for @matched_methods; + } + elsif ($method_modifier_type eq 'ARRAY') { + $meta->$add_modifier_method( $_, $code ) for @{$args->[0]}; + } + else { + throw_exception( IllegalMethodTypeToAddMethodModifier => class_or_object => $class_or_obj, + modifier_name => $modifier_name, + params => $args + ); + } + } + else { + $meta->$add_modifier_method( $_, $code ) for @{$args}; + } +} + +sub english_list { + _english_list_and(@_); +} + +sub _english_list_and { + _english_list('and', \@_); +} + +sub _english_list_or { + _english_list('or', \@_); +} + +sub _english_list { + my ($conjunction, $items) = @_; + + my @items = sort @$items; + + return $items[0] if @items == 1; + return "$items[0] $conjunction $items[1]" if @items == 2; + + my $tail = pop @items; + my $list = join ', ', @items; + $list .= ", $conjunction " . $tail; + + return $list; +} + +sub _caller_info { + my $level = @_ ? ($_[0] + 1) : 2; + my %info; + @info{qw(package file line)} = caller($level); + return %info; +} + +sub _create_alias { + my ($type, $name, $trait, $for) = @_; + my $package = _build_alias_package_name($type, $name, $trait); + Class::MOP::Class->initialize($package)->add_method( + register_implementation => sub { $for } + ); +} + +sub meta_attribute_alias { + my ($to, $from) = @_; + $from ||= caller; + my $meta = Class::MOP::class_of($from); + my $trait = $meta->isa('Moose::Meta::Role'); + _create_alias('Attribute', $to, $trait, $from); +} + +sub meta_class_alias { + my ($to, $from) = @_; + $from ||= caller; + my $meta = Class::MOP::class_of($from); + my $trait = $meta->isa('Moose::Meta::Role'); + _create_alias('Class', $to, $trait, $from); +} + +sub _load_user_class { + my ($class, $opts) = @_; + &use_package_optimistically( + $class, + $opts && $opts->{-version} ? $opts->{-version} : () + ); +} + +# XXX - this should be added to Params::Util +sub _STRINGLIKE0 ($) { + return 1 if _STRING( $_[0] ); + if ( blessed $_[0] ) { + return overload::Method( $_[0], q{""} ); + } + + return 1 if defined $_[0] && $_[0] eq q{}; + + return 0; +} + +sub _reconcile_roles_for_metaclass { + my ($class_meta_name, $super_meta_name) = @_; + + my @role_differences = _role_differences( + $class_meta_name, $super_meta_name, + ); + + # handle the case where we need to fix compatibility between a class and + # its parent, but all roles in the class are already also done by the + # parent + # see t/metaclasses/metaclass_compat_no_fixing_bug.t + return $super_meta_name + unless @role_differences; + + return Moose::Meta::Class->create_anon_class( + superclasses => [$super_meta_name], + roles => [map { $_->name } @role_differences], + cache => 1, + )->name; +} + +sub _role_differences { + my ($class_meta_name, $super_meta_name) = @_; + my @super_role_metas = map { + $_->isa('Moose::Meta::Role::Composite') + ? (@{ $_->get_roles }) + : ($_) + } $super_meta_name->meta->can('_roles_with_inheritance') + ? $super_meta_name->meta->_roles_with_inheritance + : $super_meta_name->meta->can('roles') + ? @{ $super_meta_name->meta->roles } + : (); + my @role_metas = map { + $_->isa('Moose::Meta::Role::Composite') + ? (@{ $_->get_roles }) + : ($_) + } $class_meta_name->meta->can('_roles_with_inheritance') + ? $class_meta_name->meta->_roles_with_inheritance + : $class_meta_name->meta->can('roles') + ? @{ $class_meta_name->meta->roles } + : (); + my @differences; + for my $role_meta (@role_metas) { + push @differences, $role_meta + unless any { $_->name eq $role_meta->name } @super_role_metas; + } + return @differences; +} + +sub _classes_differ_by_roles_only { + my ( $self_meta_name, $super_meta_name ) = @_; + + my $common_base_name + = _find_common_base( $self_meta_name, $super_meta_name ); + + return unless defined $common_base_name; + + my @super_meta_name_ancestor_names + = _get_ancestors_until( $super_meta_name, $common_base_name ); + my @class_meta_name_ancestor_names + = _get_ancestors_until( $self_meta_name, $common_base_name ); + + return + unless all { _is_role_only_subclass($_) } + @super_meta_name_ancestor_names, + @class_meta_name_ancestor_names; + + return 1; +} + +sub _find_common_base { + my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; + return unless defined $meta1 && defined $meta2; + + # FIXME? This doesn't account for multiple inheritance (not sure + # if it needs to though). For example, if somewhere in $meta1's + # history it inherits from both ClassA and ClassB, and $meta2 + # inherits from ClassB & ClassA, does it matter? And what crazy + # fool would do that anyway? + + my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa; + + return first { $meta1_parents{$_} } $meta2->linearized_isa; +} + +sub _get_ancestors_until { + my ($start_name, $until_name) = @_; + + my @ancestor_names; + for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) { + last if $ancestor_name eq $until_name; + push @ancestor_names, $ancestor_name; + } + return @ancestor_names; +} + +sub _is_role_only_subclass { + my ($meta_name) = @_; + my $meta = Class::MOP::Class->initialize($meta_name); + my @parent_names = $meta->superclasses; + + # XXX: don't feel like messing with multiple inheritance here... what would + # that even do? + return unless @parent_names == 1; + my ($parent_name) = @parent_names; + my $parent_meta = Class::MOP::Class->initialize($parent_name); + + # only get the roles attached to this particular class, don't look at + # superclasses + my @roles = $meta->can('calculate_all_roles') + ? $meta->calculate_all_roles + : (); + + # it's obviously not a role-only subclass if it doesn't do any roles + return unless @roles; + + # loop over all methods that are a part of the current class + # (not inherited) + for my $method ( $meta->_get_local_methods ) { + # always ignore meta + next if $method->isa('Class::MOP::Method::Meta'); + # we'll deal with attributes below + next if $method->can('associated_attribute'); + # if the method comes from a role we consumed, ignore it + next if $meta->can('does_role') + && $meta->does_role($method->original_package_name); + # FIXME - this really isn't right. Just because a modifier is + # defined in a role doesn't mean it isn't _also_ defined in the + # subclass. + next if $method->isa('Class::MOP::Method::Wrapped') + && ( + (!scalar($method->around_modifiers) + || any { $_->has_around_method_modifiers($method->name) } @roles) + && (!scalar($method->before_modifiers) + || any { $_->has_before_method_modifiers($method->name) } @roles) + && (!scalar($method->after_modifiers) + || any { $_->has_after_method_modifiers($method->name) } @roles) + ); + + return 0; + } + + # loop over all attributes that are a part of the current class + # (not inherited) + # FIXME - this really isn't right. Just because an attribute is + # defined in a role doesn't mean it isn't _also_ defined in the + # subclass. + for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) { + next if any { $_->has_attribute($attr->name) } @roles; + + return 0; + } + + return 1; +} + +sub _is_package_loaded { + my ($package) = @_; + defined $INC{module_notional_filename($package)}; +} + +1; + +# ABSTRACT: Utilities for working with Moose classes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Util - Utilities for working with Moose classes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Moose::Util qw/find_meta does_role search_class_by_role/; + + my $meta = find_meta($object) || die "No metaclass found"; + + if (does_role($object, $role)) { + print "The object can do $role!\n"; + } + + my $class = search_class_by_role($object, 'FooRole'); + print "Nearest class with 'FooRole' is $class\n"; + +=head1 DESCRIPTION + +This module provides a set of utility functions. Many of these +functions are intended for use in Moose itself or MooseX modules, but +some of them may be useful for use in your own code. + +=head1 EXPORTED FUNCTIONS + +=over 4 + +=item B<find_meta($class_or_obj)> + +This method takes a class name or object and attempts to find a +metaclass for the class, if one exists. It will B<not> create one if it +does not yet exist. + +=item B<is_role($package_or_obj)> + +Returns true if the provided package name or object is a L<Moose::Role>. + +=item B<does_role($class_or_obj, $role_or_obj)> + +Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can +be provided as a name or a L<Moose::Meta::Role> object. + +The class must already have a metaclass for this to work. If it doesn't, this +function simply returns false. + +=item B<search_class_by_role($class_or_obj, $role_or_obj)> + +Returns the first class in the class's precedence list that does +C<$role_or_obj>, if any. The role can be either a name or a +L<Moose::Meta::Role> object. + +The class must already have a metaclass for this to work. + +=item B<apply_all_roles($applicant, @roles)> + +This function applies one or more roles to the given C<$applicant>. The +applicant can be a role name, class name, or object. + +The C<$applicant> must already have a metaclass object. + +The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects, +each of which can be followed by an optional hash reference of options +(C<-excludes> and C<-alias>). + +=item B<ensure_all_roles($applicant, @roles)> + +This function is similar to C<apply_all_roles>, but only applies roles that +C<$applicant> does not already consume. + +=item B<with_traits($class_name, @role_names)> + +This function creates a new class from C<$class_name> with each of +C<@role_names> applied. It returns the name of the new class. + +=item B<get_all_attribute_values($meta, $instance)> + +Returns a hash reference containing all of the C<$instance>'s +attributes. The keys are attribute names. + +=item B<get_all_init_args($meta, $instance)> + +Returns a hash reference containing all of the C<init_arg> values for +the instance's attributes. The values are the associated attribute +values. If an attribute does not have a defined C<init_arg>, it is +skipped. + +This could be useful in cloning an object. + +=item B<resolve_metaclass_alias($category, $name, %options)> + +=item B<resolve_metatrait_alias($category, $name, %options)> + +Resolves a short name to a full class name. Short names are often used +when specifying the C<metaclass> or C<traits> option for an attribute: + + has foo => ( + metaclass => "Bar", + ); + +The name resolution mechanism is covered in +L<Moose/Metaclass and Trait Name Resolution>. + +=item B<meta_class_alias($to[, $from])> + +=item B<meta_attribute_alias($to[, $from])> + +Create an alias from the class C<$from> (or the current package, if +C<$from> is unspecified), so that +L<Moose/Metaclass and Trait Name Resolution> works properly. + +=item B<english_list(@items)> + +Given a list of scalars, turns them into a proper list in English +("one and two", "one, two, three, and four"). This is used to help us +make nicer error messages. + +=item B<throw_exception( $class_name, %arguments_to_exception)> + +Calls die with an object of Moose::Exception::$class_name, with +%arguments_to_exception passed as arguments. + +=back + +=head1 TODO + +Here is a list of possible functions to write + +=over 4 + +=item discovering original method from modified method + +=item search for origin class of a method or attribute + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Util/MetaRole.pm b/lib/Moose/Util/MetaRole.pm new file mode 100644 index 0000000..c85bc3c --- /dev/null +++ b/lib/Moose/Util/MetaRole.pm @@ -0,0 +1,329 @@ +package Moose::Util::MetaRole; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use Scalar::Util 'blessed'; + +use List::Util 1.33 qw( first all ); +use Moose::Deprecated; +use Moose::Util 'throw_exception'; + +sub apply_metaroles { + my %args = @_; + + my $for = _metathing_for( $args{for} ); + + if ( $for->isa('Moose::Meta::Role') ) { + return _make_new_metaclass( $for, $args{role_metaroles}, 'role' ); + } + else { + return _make_new_metaclass( $for, $args{class_metaroles}, 'class' ); + } +} + +sub _metathing_for { + my $passed = shift; + + my $found + = blessed $passed + ? $passed + : Class::MOP::class_of($passed); + + return $found + if defined $found + && blessed $found + && ( $found->isa('Moose::Meta::Role') + || $found->isa('Moose::Meta::Class') ); + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + + throw_exception( InvalidArgPassedToMooseUtilMetaRole => argument => $passed ); +} + +sub _make_new_metaclass { + my $for = shift; + my $roles = shift; + my $primary = shift; + + return $for unless keys %{$roles}; + + my $new_metaclass + = exists $roles->{$primary} + ? _make_new_class( ref $for, $roles->{$primary} ) + : blessed $for; + + my %classes; + + for my $key ( grep { $_ ne $primary } keys %{$roles} ) { + my $attr = first {$_} + map { $for->meta->find_attribute_by_name($_) } ( + $key . '_metaclass', + $key . '_class' + ); + + my $reader = $attr->get_read_method; + + $classes{ $attr->init_arg } + = _make_new_class( $for->$reader(), $roles->{$key} ); + } + + my $new_meta = $new_metaclass->reinitialize( $for, %classes ); + + return $new_meta; +} + +sub apply_base_class_roles { + my %args = @_; + + my $meta = _metathing_for( $args{for} || $args{for_class} ); + throw_exception( CannotApplyBaseClassRolesToRole => params => \%args, + role_name => $meta->name, + ) + if $meta->isa('Moose::Meta::Role'); + + my $new_base = _make_new_class( + $meta->name, + $args{roles}, + [ $meta->superclasses() ], + ); + + $meta->superclasses($new_base) + if $new_base ne $meta->name(); +} + +sub _make_new_class { + my $existing_class = shift; + my $roles = shift; + my $superclasses = shift || [$existing_class]; + + return $existing_class unless $roles; + + my $meta = Class::MOP::Class->initialize($existing_class); + + return $existing_class + if $meta->can('does_role') && all { $meta->does_role($_) } + grep { !ref $_ } @{$roles}; + + return Moose::Meta::Class->create_anon_class( + superclasses => $superclasses, + roles => $roles, + cache => 1, + )->name(); +} + +1; + +# ABSTRACT: Apply roles to any metaclass, as well as the object base class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyApp::Moose; + + use Moose (); + use Moose::Exporter; + use Moose::Util::MetaRole; + + 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 %args = @_; + + Moose->init_meta(%args); + + Moose::Util::MetaRole::apply_metaroles( + for => $args{for_class}, + class_metaroles => { + class => ['MyApp::Role::Meta::Class'], + constructor => ['MyApp::Role::Meta::Method::Constructor'], + }, + ); + + Moose::Util::MetaRole::apply_base_class_roles( + for => $args{for_class}, + roles => ['MyApp::Role::Object'], + ); + + return $args{for_class}->meta(); + } + +=head1 DESCRIPTION + +This utility module is designed to help authors of Moose extensions +write extensions that are able to cooperate with other Moose +extensions. To do this, you must write your extensions as roles, which +can then be dynamically applied to the caller's metaclasses. + +This module makes sure to preserve any existing superclasses and roles +already set for the meta objects, which means that any number of +extensions can apply roles in any order. + +=head1 USAGE + +The easiest way to use this module is through L<Moose::Exporter>, which can +generate the appropriate C<init_meta> method for you, and make sure it is +called when imported. + +=head1 FUNCTIONS + +This module provides two functions. + +=head2 apply_metaroles( ... ) + +This function will apply roles to one or more metaclasses for the specified +class. It will return a new metaclass object for the class or role passed in +the "for" parameter. + +It accepts the following parameters: + +=over 4 + +=item * for => $name + +This specifies the class or for which to alter the meta classes. This can be a +package name, or an appropriate meta-object (a L<Moose::Meta::Class> or +L<Moose::Meta::Role>). + +=item * class_metaroles => \%roles + +This is a hash reference specifying which metaroles will be applied to the +class metaclass and its contained metaclasses and helper classes. + +Each key should in turn point to an array reference of role names. + +It accepts the following keys: + +=over 8 + +=item class + +=item attribute + +=item method + +=item wrapped_method + +=item instance + +=item constructor + +=item destructor + +=item error + +=back + +=item * role_metaroles => \%roles + +This is a hash reference specifying which metaroles will be applied to the +role metaclass and its contained metaclasses and helper classes. + +It accepts the following keys: + +=over 8 + +=item role + +=item attribute + +=item method + +=item required_method + +=item conflicting_method + +=item application_to_class + +=item application_to_role + +=item application_to_instance + +=item application_role_summation + +=item applied_attribute + +=back + +=back + +=head2 apply_base_class_roles( for => $class, roles => \@roles ) + +This function will apply the specified roles to the object's base class. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm new file mode 100644 index 0000000..e4b75e3 --- /dev/null +++ b/lib/Moose/Util/TypeConstraints.pm @@ -0,0 +1,1459 @@ +package Moose::Util::TypeConstraints; +our $VERSION = '2.1405'; + +use Carp (); +use Scalar::Util qw( blessed ); +use Moose::Exporter; +use Moose::Deprecated; + +## -------------------------------------------------------- +# Prototyped subs must be predeclared because we have a +# circular dependency with Moose::Meta::Attribute et. al. +# so in case of us being use'd first the predeclaration +# ensures the prototypes are in scope when consumers are +# compiled. + +# dah sugah! +sub where (&); +sub via (&); +sub message (&); +sub inline_as (&); + +## -------------------------------------------------------- + +use Moose::Meta::TypeConstraint; +use Moose::Meta::TypeConstraint::Union; +use Moose::Meta::TypeConstraint::Parameterized; +use Moose::Meta::TypeConstraint::Parameterizable; +use Moose::Meta::TypeConstraint::Class; +use Moose::Meta::TypeConstraint::Role; +use Moose::Meta::TypeConstraint::Enum; +use Moose::Meta::TypeConstraint::DuckType; +use Moose::Meta::TypeCoercion; +use Moose::Meta::TypeCoercion::Union; +use Moose::Meta::TypeConstraint::Registry; + +use Moose::Util 'throw_exception'; + +Moose::Exporter->setup_import_methods( + as_is => [ + qw( + type subtype class_type role_type maybe_type duck_type + as where message inline_as + coerce from via + enum union + find_type_constraint + register_type_constraint + match_on_type ) + ], +); + +## -------------------------------------------------------- +## type registry and some useful functions for it +## -------------------------------------------------------- + +my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new; + +sub get_type_constraint_registry {$REGISTRY} +sub list_all_type_constraints { keys %{ $REGISTRY->type_constraints } } + +sub export_type_constraints_as_functions { + my $pkg = caller(); + no strict 'refs'; + foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) { + my $tc = $REGISTRY->get_type_constraint($constraint) + ->_compiled_type_constraint; + *{"${pkg}::${constraint}"} + = sub { $tc->( $_[0] ) ? 1 : undef }; # the undef is for compat + } +} + +sub create_type_constraint_union { + _create_type_constraint_union(\@_); +} + +sub create_named_type_constraint_union { + my $name = shift; + _create_type_constraint_union($name, \@_); +} + +sub _create_type_constraint_union { + my $name; + $name = shift if @_ > 1; + my @tcs = @{ shift() }; + + my @type_constraint_names; + + if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) { + @type_constraint_names = _parse_type_constraint_union( $tcs[0] ); + } + else { + @type_constraint_names = @tcs; + } + + ( scalar @type_constraint_names >= 2 ) + || throw_exception("UnionTakesAtleastTwoTypeNames"); + + my @type_constraints = map { + find_or_parse_type_constraint($_) + || throw_exception( CouldNotLocateTypeConstraintForUnion => type_name => $_ ); + } @type_constraint_names; + + my %options = ( + type_constraints => \@type_constraints + ); + $options{name} = $name if defined $name; + + return Moose::Meta::TypeConstraint::Union->new(%options); +} + + +sub create_parameterized_type_constraint { + my $type_constraint_name = shift; + my ( $base_type, $type_parameter ) + = _parse_parameterized_type_constraint($type_constraint_name); + + ( defined $base_type && defined $type_parameter ) + || throw_exception( InvalidTypeGivenToCreateParameterizedTypeConstraint => type_name => $type_constraint_name ); + + if ( $REGISTRY->has_type_constraint($base_type) ) { + my $base_type_tc = $REGISTRY->get_type_constraint($base_type); + return _create_parameterized_type_constraint( + $base_type_tc, + $type_parameter + ); + } + else { + throw_exception( InvalidBaseTypeGivenToCreateParameterizedTypeConstraint => type_name => $base_type ); + } +} + +sub _create_parameterized_type_constraint { + my ( $base_type_tc, $type_parameter ) = @_; + if ( $base_type_tc->can('parameterize') ) { + return $base_type_tc->parameterize($type_parameter); + } + else { + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $base_type_tc->name . '[' . $type_parameter . ']', + parent => $base_type_tc, + type_parameter => + find_or_create_isa_type_constraint($type_parameter), + ); + } +} + +#should we also support optimized checks? +sub create_class_type_constraint { + my ( $class, $options ) = @_; + +# too early for this check +#find_type_constraint("ClassName")->check($class) +# || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); + + my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) ); + + if (my $type = $REGISTRY->get_type_constraint($class)) { + if (!($type->isa('Moose::Meta::TypeConstraint::Class') && $type->class eq $class)) { + throw_exception( TypeConstraintIsAlreadyCreated => package_defined_in => $pkg_defined_in, + type_name => $type->name, + ); + } + else { + return $type; + } + } + + my %options = ( + class => $class, + name => $class, + package_defined_in => $pkg_defined_in, + %{ $options || {} }, # overrides options from above + ); + + $options{name} ||= "__ANON__"; + + my $tc = Moose::Meta::TypeConstraint::Class->new(%options); + $REGISTRY->add_type_constraint($tc); + return $tc; +} + +sub create_role_type_constraint { + my ( $role, $options ) = @_; + +# too early for this check +#find_type_constraint("ClassName")->check($class) +# || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); + + my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) ); + + if (my $type = $REGISTRY->get_type_constraint($role)) { + if (!($type->isa('Moose::Meta::TypeConstraint::Role') && $type->role eq $role)) { + throw_exception( TypeConstraintIsAlreadyCreated => type_name => $type->name, + package_defined_in => $pkg_defined_in + ); + } + else { + return $type; + } + } + + my %options = ( + role => $role, + name => $role, + package_defined_in => $pkg_defined_in, + %{ $options || {} }, + ); + + $options{name} ||= "__ANON__"; + + my $tc = Moose::Meta::TypeConstraint::Role->new(%options); + $REGISTRY->add_type_constraint($tc); + return $tc; +} + +sub find_or_create_type_constraint { + my ( $type_constraint_name, $options_for_anon_type ) = @_; + + if ( my $constraint + = find_or_parse_type_constraint($type_constraint_name) ) { + return $constraint; + } + elsif ( defined $options_for_anon_type ) { + + # NOTE: + # if there is no $options_for_anon_type + # specified, then we assume they don't + # want to create one, and return nothing. + + # otherwise assume that we should create + # an ANON type with the $options_for_anon_type + # options which can be passed in. It should + # be noted that these don't get registered + # so we need to return it. + # - SL + return Moose::Meta::TypeConstraint->new( + name => '__ANON__', + %{$options_for_anon_type} + ); + } + + return; +} + +sub find_or_create_isa_type_constraint { + my ($type_constraint_name, $options) = @_; + find_or_parse_type_constraint($type_constraint_name) + || create_class_type_constraint($type_constraint_name, $options); +} + +sub find_or_create_does_type_constraint { + my ($type_constraint_name, $options) = @_; + find_or_parse_type_constraint($type_constraint_name) + || create_role_type_constraint($type_constraint_name, $options); +} + +sub find_or_parse_type_constraint { + my $type_constraint_name = normalize_type_constraint_name(shift); + my $constraint; + + 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) ) { + $constraint + = create_parameterized_type_constraint($type_constraint_name); + } + else { + return; + } + + $REGISTRY->add_type_constraint($constraint); + return $constraint; +} + +sub normalize_type_constraint_name { + my $type_constraint_name = shift; + $type_constraint_name =~ s/\s//g; + return $type_constraint_name; +} + +sub _confess { + my $error = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + Carp::confess($error); +} + +## -------------------------------------------------------- +## exported functions ... +## -------------------------------------------------------- + +sub find_type_constraint { + my $type = shift; + + if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) { + return $type; + } + else { + return unless $REGISTRY->has_type_constraint($type); + return $REGISTRY->get_type_constraint($type); + } +} + +sub register_type_constraint { + my $constraint = shift; + throw_exception( CannotRegisterUnnamedTypeConstraint => type => $constraint ) + unless defined $constraint->name; + $REGISTRY->add_type_constraint($constraint); + return $constraint; +} + +# type constructors + +sub type { + my $name = shift; + + my %p = map { %{$_} } @_; + + return _create_type_constraint( + $name, undef, $p{where}, $p{message}, + $p{inline_as}, + ); +} + +sub subtype { + if ( @_ == 1 && !ref $_[0] ) { + throw_exception( NoParentGivenToSubtype => name => $_[0] ); + } + + # The blessed check is mostly to accommodate MooseX::Types, which + # uses an object which overloads stringification as a type name. + my $name = ref $_[0] && !blessed $_[0] ? undef : shift; + + my %p = map { %{$_} } @_; + + # subtype Str => where { ... }; + if ( !exists $p{as} ) { + $p{as} = $name; + $name = undef; + } + + return _create_type_constraint( + $name, $p{as}, $p{where}, $p{message}, + $p{inline_as}, + ); +} + +sub class_type { + create_class_type_constraint(@_); +} + +sub role_type ($;$) { + create_role_type_constraint(@_); +} + +sub maybe_type { + my ($type_parameter) = @_; + + register_type_constraint( + $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter) + ); +} + +sub duck_type { + my ( $type_name, @methods ) = @_; + if ( ref $type_name eq 'ARRAY' && !@methods ) { + @methods = ($type_name); + $type_name = undef; + } + if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) { + @methods = @{ $methods[0] }; + } + else { + Moose::Deprecated::deprecated( + feature => 'non-arrayref form of duck_type', + message => "Passing a list of values to duck_type is deprecated. " + . "The method names should be wrapped in an arrayref.", + ); + } + + register_type_constraint( + create_duck_type_constraint( + $type_name, + \@methods, + ) + ); +} + +sub coerce { + my ( $type_name, @coercion_map ) = @_; + _install_type_coercions( $type_name, \@coercion_map ); +} + +# The trick of returning @_ lets us avoid having to specify a +# prototype. Perl will parse this: +# +# subtype 'Foo' +# => as 'Str' +# => where { ... } +# +# as this: +# +# subtype( 'Foo', as( 'Str', where { ... } ) ); +# +# If as() returns all its extra arguments, this just works, and +# preserves backwards compatibility. +sub as { { as => shift }, @_ } +sub where (&) { { where => $_[0] } } +sub message (&) { { message => $_[0] } } +sub inline_as (&) { { inline_as => $_[0] } } + +sub from {@_} +sub via (&) { $_[0] } + +sub enum { + my ( $type_name, @values ) = @_; + + # NOTE: + # if only an array-ref is passed then + # you get an anon-enum + # - SL + if ( ref $type_name eq 'ARRAY' ) { + @values == 0 + || throw_exception( EnumCalledWithAnArrayRefAndAdditionalArgs => array => $type_name, + args => \@values + ); + @values = ($type_name); + $type_name = undef; + } + if ( @values == 1 && ref $values[0] eq 'ARRAY' ) { + @values = @{ $values[0] }; + } + else { + Moose::Deprecated::deprecated( + feature => 'non-arrayref form of enum', + message => "Passing a list of values to enum is deprecated. " + . "Enum values should be wrapped in an arrayref.", + ); + } + + register_type_constraint( + create_enum_type_constraint( + $type_name, + \@values, + ) + ); +} + +sub union { + my ( $type_name, @constraints ) = @_; + if ( ref $type_name eq 'ARRAY' ) { + @constraints == 0 + || throw_exception( UnionCalledWithAnArrayRefAndAdditionalArgs => array => $type_name, + args => \@constraints + ); + @constraints = @$type_name; + $type_name = undef; + } + if ( @constraints == 1 && ref $constraints[0] eq 'ARRAY' ) { + @constraints = @{ $constraints[0] }; + } + if ( defined $type_name ) { + return register_type_constraint( + create_named_type_constraint_union( $type_name, @constraints ) + ); + } + return create_type_constraint_union( @constraints ); +} + +sub create_enum_type_constraint { + my ( $type_name, $values ) = @_; + + Moose::Meta::TypeConstraint::Enum->new( + name => $type_name || '__ANON__', + values => $values, + ); +} + +sub create_duck_type_constraint { + my ( $type_name, $methods ) = @_; + + Moose::Meta::TypeConstraint::DuckType->new( + name => $type_name || '__ANON__', + methods => $methods, + ); +} + +sub match_on_type { + my ($to_match, @cases) = @_; + my $default; + if (@cases % 2 != 0) { + $default = pop @cases; + (ref $default eq 'CODE') + || throw_exception( DefaultToMatchOnTypeMustBeCodeRef => to_match => $to_match, + default_action => $default, + cases_to_be_matched => \@cases + ); + } + while (@cases) { + my ($type, $action) = splice @cases, 0, 2; + + unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) { + $type = find_or_parse_type_constraint($type) + || throw_exception( CannotFindTypeGivenToMatchOnType => type => $type, + to_match => $to_match, + action => $action + ); + } + + (ref $action eq 'CODE') + || throw_exception( MatchActionMustBeACodeRef => type_name => $type->name, + action => $action, + to_match => $to_match + ); + + if ($type->check($to_match)) { + local $_ = $to_match; + return $action->($to_match); + } + } + (defined $default) + || throw_exception( NoCasesMatched => to_match => $to_match, + cases_to_be_matched => \@cases + ); + { + local $_ = $to_match; + return $default->($to_match); + } +} + + +## -------------------------------------------------------- +## desugaring functions ... +## -------------------------------------------------------- + +sub _create_type_constraint ($$$;$) { + my $name = shift; + my $parent = shift; + my $check = shift; + my $message = shift; + my $inlined = shift; + + my $pkg_defined_in = scalar( caller(1) ); + + if ( defined $name ) { + my $type = $REGISTRY->get_type_constraint($name); + + ( $type->_package_defined_in eq $pkg_defined_in ) + || throw_exception( TypeConstraintIsAlreadyCreated => package_defined_in => $pkg_defined_in, + type_name => $type->name, + ) + if defined $type; + + if( $name !~ /^[\w:\.]+$/ ) { + throw_exception( InvalidNameForType => name => $name ); + } + } + + my %opts = ( + name => $name, + package_defined_in => $pkg_defined_in, + + ( $check ? ( constraint => $check ) : () ), + ( $message ? ( message => $message ) : () ), + ( $inlined ? ( inlined => $inlined ) : () ), + ); + + my $constraint; + if ( + defined $parent + and $parent + = blessed $parent + ? $parent + : find_or_create_isa_type_constraint($parent) + ) { + $constraint = $parent->create_child_type(%opts); + } + else { + $constraint = Moose::Meta::TypeConstraint->new(%opts); + } + + $REGISTRY->add_type_constraint($constraint) + if defined $name; + + return $constraint; +} + +sub _install_type_coercions ($$) { + my ( $type_name, $coercion_map ) = @_; + my $type = find_type_constraint($type_name); + ( defined $type ) + || throw_exception( CannotFindType => type_name => $type_name ); + + if ( $type->has_coercion ) { + $type->coercion->add_type_coercions(@$coercion_map); + } + else { + my $type_coercion = Moose::Meta::TypeCoercion->new( + type_coercion_map => $coercion_map, + type_constraint => $type + ); + $type->coercion($type_coercion); + } +} + +## -------------------------------------------------------- +## type notation parsing ... +## -------------------------------------------------------- + +{ + + # All I have to say is mugwump++ cause I know + # do not even have enough regexp-fu to be able + # to have written this (I can only barely + # understand it as it is) + # - SL + + use re "eval"; + + my $valid_chars = qr{[\w:\.]}; + my $type_atom = qr{ (?>$valid_chars+) }x; + my $ws = qr{ (?>\s*) }x; + my $op_union = qr{ $ws \| $ws }x; + + my ($type, $type_capture_parts, $type_with_parameter, $union, $any); + if (Class::MOP::IS_RUNNING_ON_5_10) { + my $type_pattern + = q{ (?&type_atom) (?: \[ (?&ws) (?&any) (?&ws) \] )? }; + my $type_capture_parts_pattern + = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? }; + my $type_with_parameter_pattern + = q{ (?&type_atom) \[ (?&ws) (?&any) (?&ws) \] }; + my $union_pattern + = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) }; + my $any_pattern + = q{ (?&type) | (?&union) }; + + my $defines = qr{(?(DEFINE) + (?<valid_chars> $valid_chars) + (?<type_atom> $type_atom) + (?<ws> $ws) + (?<op_union> $op_union) + (?<type> $type_pattern) + (?<type_capture_parts> $type_capture_parts_pattern) + (?<type_with_parameter> $type_with_parameter_pattern) + (?<union> $union_pattern) + (?<any> $any_pattern) + )}x; + + $type = qr{ $type_pattern $defines }x; + $type_capture_parts = qr{ $type_capture_parts_pattern $defines }x; + $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x; + $union = qr{ $union_pattern $defines }x; + $any = qr{ $any_pattern $defines }x; + } + else { + $type + = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x; + $type_capture_parts + = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x; + $type_with_parameter + = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x; + $union + = qr{ $type (?> (?: $op_union $type )+ ) }x; + $any + = qr{ $type | $union }x; + } + + + sub _parse_parameterized_type_constraint { + { no warnings 'void'; $any; } # force capture of interpolated lexical + $_[0] =~ m{ $type_capture_parts }x; + return ( $1, $2 ); + } + + sub _detect_parameterized_type_constraint { + { no warnings 'void'; $any; } # force capture of interpolated lexical + $_[0] =~ m{ ^ $type_with_parameter $ }x; + } + + sub _parse_type_constraint_union { + { no warnings 'void'; $any; } # force capture of interpolated lexical + my $given = shift; + my @rv; + while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) { + push @rv => $1; + } + ( pos($given) eq length($given) ) + || throw_exception( CouldNotParseType => type => $given, + position => pos($given) + ); + @rv; + } + + sub _detect_type_constraint_union { + { no warnings 'void'; $any; } # force capture of interpolated lexical + $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x; + } +} + +## -------------------------------------------------------- +# define some basic built-in types +## -------------------------------------------------------- + +# By making these classes immutable before creating all the types in +# Moose::Util::TypeConstraints::Builtin , we avoid repeatedly calling the slow +# MOP-based accessors. +$_->make_immutable( + inline_constructor => 1, + constructor_name => "_new", + + # these are Class::MOP accessors, so they need inlining + inline_accessors => 1 + ) for grep { $_->is_mutable } + map { Class::MOP::class_of($_) } + qw( + Moose::Meta::TypeConstraint + Moose::Meta::TypeConstraint::Union + Moose::Meta::TypeConstraint::Parameterized + Moose::Meta::TypeConstraint::Parameterizable + Moose::Meta::TypeConstraint::Class + Moose::Meta::TypeConstraint::Role + Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::DuckType + Moose::Meta::TypeConstraint::Registry +); + +require Moose::Util::TypeConstraints::Builtins; +Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY); + +my @PARAMETERIZABLE_TYPES + = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe]; + +sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES} + +sub add_parameterizable_type { + my $type = shift; + ( blessed $type + && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') ) + || throw_exception( AddParameterizableTypeTakesParameterizableType => type_name => $type ); + + push @PARAMETERIZABLE_TYPES => $type; +} + +## -------------------------------------------------------- +# end of built-in types ... +## -------------------------------------------------------- + +{ + my @BUILTINS = list_all_type_constraints(); + sub list_all_builtin_type_constraints {@BUILTINS} +} + +1; + +# ABSTRACT: Type constraint system for Moose + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Util::TypeConstraints - Type constraint system for Moose + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Moose::Util::TypeConstraints; + + subtype 'Natural', + as 'Int', + where { $_ > 0 }; + + subtype 'NaturalLessThanTen', + as 'Natural', + where { $_ < 10 }, + message { "This number ($_) is not less than ten!" }; + + coerce 'Num', + from 'Str', + via { 0+$_ }; + + class_type 'DateTimeClass', { class => 'DateTime' }; + + role_type 'Barks', { role => 'Some::Library::Role::Barks' }; + + enum 'RGBColors', [qw(red green blue)]; + + union 'StringOrArray', [qw( String ArrayRef )]; + + no Moose::Util::TypeConstraints; + +=head1 DESCRIPTION + +This module provides Moose with the ability to create custom type +constraints to be used in attribute definition. + +=head2 Important Caveat + +This is B<NOT> a type system for Perl 5. These are type constraints, +and they are not used by Moose unless you tell it to. No type +inference is performed, expressions are not typed, etc. etc. etc. + +A type constraint is at heart a small "check if a value is valid" +function. A constraint can be associated with an attribute. This +simplifies parameter validation, and makes your code clearer to read, +because you can refer to constraints by name. + +=head2 Slightly Less Important Caveat + +It is B<always> a good idea to quote your type names. + +This prevents Perl from trying to execute the call as an indirect +object call. This can be an issue when you have a subtype with the +same name as a valid class. + +For instance: + + subtype DateTime => as Object => where { $_->isa('DateTime') }; + +will I<just work>, while this: + + use DateTime; + subtype DateTime => as Object => where { $_->isa('DateTime') }; + +will fail silently and cause many headaches. The simple way to solve +this, as well as future proof your subtypes from classes which have +yet to have been created, is to quote the type name: + + use DateTime; + subtype 'DateTime', as 'Object', where { $_->isa('DateTime') }; + +=head2 Default Type Constraints + +This module also provides a simple hierarchy for Perl 5 types, here is +that hierarchy represented visually. + + Any + Item + Bool + Maybe[`a] + Undef + Defined + Value + Str + Num + Int + ClassName + RoleName + Ref + ScalarRef[`a] + ArrayRef[`a] + HashRef[`a] + CodeRef + RegexpRef + GlobRef + FileHandle + Object + +B<NOTE:> Any type followed by a type parameter C<[`a]> can be +parameterized, this means you can say: + + ArrayRef[Int] # an array of integers + HashRef[CodeRef] # a hash of str to CODE ref mappings + ScalarRef[Int] # a reference to an integer + Maybe[Str] # value may be a string, may be undefined + +If Moose finds a name in brackets that it does not recognize as an +existing type, it assumes that this is a class name, for example +C<ArrayRef[DateTime]>. + +B<NOTE:> Unless you parameterize a type, then it is invalid to include +the square brackets. I.e. C<ArrayRef[]> will be treated as a new type +name, I<not> as a parameterization of C<ArrayRef>. + +B<NOTE:> The C<Undef> type constraint for the most part works +correctly now, but edge cases may still exist, please use it +sparingly. + +B<NOTE:> The C<ClassName> type constraint does a complex package +existence check. This means that your class B<must> be loaded for this +type constraint to pass. + +B<NOTE:> The C<RoleName> constraint checks a string is a I<package +name> which is a role, like C<'MyApp::Role::Comparable'>. + +=head2 Type Constraint Naming + +Type name declared via this module can only contain alphanumeric +characters, colons (:), and periods (.). + +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::Types::Color> instead. + +=head2 Use with Other Constraint Modules + +This module can play nicely with other constraint modules with some +slight tweaking. The C<where> clause in types is expected to be a +C<CODE> reference which checks its first argument and returns a +boolean. Since most constraint modules work in a similar way, it +should be simple to adapt them to work with Moose. + +For instance, this is how you could use it with +L<Declare::Constraints::Simple> to declare a completely new type. + + type 'HashOfArrayOfObjects', + where { + IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + )->(@_); + }; + +For more examples see the F<t/examples/example_w_DCS.t> test +file. + +Here is an example of using L<Test::Deep> and its non-test +related C<eq_deeply> function. + + type 'ArrayOfHashOfBarsAndRandomNumbers', + where { + eq_deeply($_, + array_each(subhashof({ + bar => isa('Bar'), + random_number => ignore() + }))) + }; + +For a complete example see the +F<t/examples/example_w_TestDeep.t> test file. + +=head2 Error messages + +Type constraints can also specify custom error messages, for when they fail to +validate. This is provided as just another coderef, which receives the invalid +value in C<$_>, as in: + + subtype 'PositiveInt', + as 'Int', + where { $_ > 0 }, + message { "$_ is not a positive integer!" }; + +If no message is specified, a default message will be used, which indicates +which type constraint was being used and what value failed. If +L<Devel::PartialDump> (version 0.14 or higher) is installed, it will be used to +display the invalid value, otherwise it will just be printed as is. + +=head1 FUNCTIONS + +=head2 Type Constraint Constructors + +The following functions are used to create type constraints. They +will also register the type constraints your create in a global +registry that is used to look types up by name. + +See the L</SYNOPSIS> for an example of how to use these. + +=over 4 + +=item B<< subtype 'Name', as 'Parent', where { } ... >> + +This creates a named subtype. + +If you provide a parent that Moose does not recognize, it will +automatically create a new class type constraint for this name. + +When creating a named type, the C<subtype> function should either be +called with the sugar helpers (C<where>, C<message>, etc), or with a +name and a hashref of parameters: + + subtype( 'Foo', { where => ..., message => ... } ); + +The valid hashref keys are C<as> (the parent), C<where>, C<message>, +and C<inline_as>. + +=item B<< subtype as 'Parent', where { } ... >> + +This creates an unnamed subtype and will return the type +constraint meta-object, which will be an instance of +L<Moose::Meta::TypeConstraint>. + +When creating an anonymous type, the C<subtype> function should either +be called with the sugar helpers (C<where>, C<message>, etc), or with +just a hashref of parameters: + + subtype( { where => ..., message => ... } ); + +=item B<class_type ($class, ?$options)> + +Creates a new subtype of C<Object> with the name C<$class> and the +metaclass L<Moose::Meta::TypeConstraint::Class>. + + # Create a type called 'Box' which tests for objects which ->isa('Box') + class_type 'Box'; + +By default, the name of the type and the name of the class are the same, but +you can specify both separately. + + # Create a type called 'Box' which tests for objects which ->isa('ObjectLibrary::Box'); + class_type 'Box', { class => 'ObjectLibrary::Box' }; + +=item B<role_type ($role, ?$options)> + +Creates a C<Role> type constraint with the name C<$role> and the +metaclass L<Moose::Meta::TypeConstraint::Role>. + + # Create a type called 'Walks' which tests for objects which ->does('Walks') + role_type 'Walks'; + +By default, the name of the type and the name of the role are the same, but +you can specify both separately. + + # Create a type called 'Walks' which tests for objects which ->does('MooseX::Role::Walks'); + role_type 'Walks', { role => 'MooseX::Role::Walks' }; + +=item B<maybe_type ($type)> + +Creates a type constraint for either C<undef> or something of the +given type. + +=item B<duck_type ($name, \@methods)> + +This will create a subtype of Object and test to make sure the value +C<can()> do the methods in C<\@methods>. + +This is intended as an easy way to accept non-Moose objects that +provide a certain interface. If you're using Moose classes, we +recommend that you use a C<requires>-only Role instead. + +=item B<duck_type (\@methods)> + +If passed an ARRAY reference as the only parameter instead of the +C<$name>, C<\@methods> pair, this will create an unnamed duck type. +This can be used in an attribute definition like so: + + has 'cache' => ( + is => 'ro', + isa => duck_type( [qw( get_set )] ), + ); + +=item B<enum ($name, \@values)> + +This will create a basic subtype for a given set of strings. +The resulting constraint will be a subtype of C<Str> and +will match any of the items in C<\@values>. It is case sensitive. +See the L</SYNOPSIS> for a simple example. + +B<NOTE:> This is not a true proper enum type, it is simply +a convenient constraint builder. + +=item B<enum (\@values)> + +If passed an ARRAY reference as the only parameter instead of the +C<$name>, C<\@values> pair, this will create an unnamed enum. This +can then be used in an attribute definition like so: + + has 'sort_order' => ( + is => 'ro', + isa => enum([qw[ ascending descending ]]), + ); + +=item B<union ($name, \@constraints)> + +This will create a basic subtype where any of the provided constraints +may match in order to satisfy this constraint. + +=item B<union (\@constraints)> + +If passed an ARRAY reference as the only parameter instead of the +C<$name>, C<\@constraints> pair, this will create an unnamed union. +This can then be used in an attribute definition like so: + + has 'items' => ( + is => 'ro', + isa => union([qw[ Str ArrayRef ]]), + ); + +This is similar to the existing string union: + + isa => 'Str|ArrayRef' + +except that it supports anonymous elements as child constraints: + + has 'color' => ( + isa => 'ro', + isa => union([ 'Int', enum([qw[ red green blue ]]) ]), + ); + +=item B<as 'Parent'> + +This is just sugar for the type constraint construction syntax. + +It takes a single argument, which is the name of a parent type. + +=item B<where { ... }> + +This is just sugar for the type constraint construction syntax. + +It takes a subroutine reference as an argument. When the type +constraint is tested, the reference is run with the value to be tested +in C<$_>. This reference 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. + +It takes a subroutine reference as an argument. When the type +constraint fails, then the code block is run with the value provided +in C<$_>. This reference should return a string, which will be used in +the text of the exception thrown. + +=item B<inline_as { ... }> + +This can be used to define a "hand optimized" inlinable version of your type +constraint. + +You provide a subroutine which will be called I<as a method> on a +L<Moose::Meta::TypeConstraint> object. It will receive a single parameter, the +name of the variable to check, typically something like C<"$_"> or C<"$_[0]">. + +The subroutine should return a code string suitable for inlining. You can +assume that the check will be wrapped in parentheses when it is inlined. + +The inlined code should include any checks that your type's parent types +do. If your parent type constraint defines its own inlining, you can simply use +that to avoid repeating code. For example, here is the inlining code for the +C<Value> type, which is a subtype of C<Defined>: + + sub { + $_[0]->parent()->_inline_check($_[1]) + . ' && !ref(' . $_[1] . ')' + } + +=item B<< type 'Name', where { } ... >> + +This creates a base type, which has no parent. + +The C<type> function should either be called with the sugar helpers +(C<where>, C<message>, etc), or with a name and a hashref of +parameters: + + type( 'Foo', { where => ..., message => ... } ); + +The valid hashref keys are C<where>, C<message>, and C<inlined_as>. + +=back + +=head2 Type Constraint Utilities + +=over 4 + +=item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >> + +This is a utility function for doing simple type based dispatching similar to +match/case in OCaml and case/of in Haskell. It is not as featureful as those +languages, nor does not it support any kind of automatic destructuring +bind. Here is a simple Perl pretty printer dispatching over the core Moose +types. + + sub ppprint { + my $x = shift; + match_on_type $x => ( + HashRef => sub { + my $hash = shift; + '{ ' + . ( + join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) } + sort keys %$hash + ) . ' }'; + }, + ArrayRef => sub { + my $array = shift; + '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]'; + }, + CodeRef => sub {'sub { ... }'}, + RegexpRef => sub { 'qr/' . $_ . '/' }, + GlobRef => sub { '*' . B::svref_2object($_)->NAME }, + Object => sub { $_->can('to_string') ? $_->to_string : $_ }, + ScalarRef => sub { '\\' . ppprint( ${$_} ) }, + Num => sub {$_}, + Str => sub { '"' . $_ . '"' }, + Undef => sub {'undef'}, + => sub { die "I don't know what $_ is" } + ); + } + +Or a simple JSON serializer: + + sub to_json { + my $x = shift; + match_on_type $x => ( + HashRef => sub { + my $hash = shift; + '{ ' + . ( + join ", " => + map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) } + sort keys %$hash + ) . ' }'; + }, + ArrayRef => sub { + my $array = shift; + '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]'; + }, + Num => sub {$_}, + Str => sub { '"' . $_ . '"' }, + Undef => sub {'null'}, + => sub { die "$_ is not acceptable json type" } + ); + } + +The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can +be either a string type or a L<Moose::Meta::TypeConstraint> object, and +C<\&action> is a subroutine reference. This function will dispatch on the +first match for C<$value>. It is possible to have a catch-all by providing an +additional subroutine reference as the final argument to C<match_on_type>. + +=back + +=head2 Type Coercion Constructors + +You can define coercions for type constraints, which allow you to +automatically transform values to something valid for the type +constraint. If you ask your accessor to coerce, then Moose will run +the type-coercion code first, followed by the type constraint +check. This feature should be used carefully as it is very powerful +and could easily take off a limb if you are not careful. + +See the L</SYNOPSIS> for an example of how to use these. + +=over 4 + +=item B<< coerce 'Name', from 'OtherName', via { ... } >> + +This defines a coercion from one type to another. The C<Name> argument +is the type you are coercing I<to>. + +To define multiple coercions, supply more sets of from/via pairs: + + coerce 'Name', + from 'OtherName', via { ... }, + from 'ThirdName', via { ... }; + +=item B<from 'OtherName'> + +This is just sugar for the type coercion construction syntax. + +It takes a single type name (or type object), which is the type being +coerced I<from>. + +=item B<via { ... }> + +This is just sugar for the type coercion construction syntax. + +It takes a subroutine reference. This reference will be called with +the value to be coerced in C<$_>. It is expected to return a new value +of the proper type for the coercion. + +=back + +=head2 Creating and Finding Type Constraints + +These are additional functions for creating and finding type +constraints. Most of these functions are not available for +importing. The ones that are importable as specified. + +=over 4 + +=item B<find_type_constraint($type_name)> + +This function can be used to locate the L<Moose::Meta::TypeConstraint> +object for a named type. + +This function is importable. + +=item B<register_type_constraint($type_object)> + +This function will register a L<Moose::Meta::TypeConstraint> with the +global type registry. + +This function is importable. + +=item B<normalize_type_constraint_name($type_constraint_name)> + +This method takes a type constraint name and returns the normalized +form. This removes any whitespace in the string. + +=item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)> + +=item B<create_named_type_constraint_union($name, $pipe_separated_types | @type_constraint_names)> + +This can take a union type specification like C<'Int|ArrayRef[Int]'>, +or a list of names. It returns a new +L<Moose::Meta::TypeConstraint::Union> object. + +=item B<create_parameterized_type_constraint($type_name)> + +Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>, +this will create a new L<Moose::Meta::TypeConstraint::Parameterized> +object. The C<BaseType> must already exist as a parameterizable +type. + +=item B<create_class_type_constraint($class, $options)> + +Given a class name this function will create a new +L<Moose::Meta::TypeConstraint::Class> object for that class name. + +The C<$options> is a hash reference that will be passed to the +L<Moose::Meta::TypeConstraint::Class> constructor (as a hash). + +=item B<create_role_type_constraint($role, $options)> + +Given a role name this function will create a new +L<Moose::Meta::TypeConstraint::Role> object for that role name. + +The C<$options> is a hash reference that will be passed to the +L<Moose::Meta::TypeConstraint::Role> constructor (as a hash). + +=item B<create_enum_type_constraint($name, $values)> + +Given a enum name this function will create a new +L<Moose::Meta::TypeConstraint::Enum> object for that enum name. + +=item B<create_duck_type_constraint($name, $methods)> + +Given a duck type name this function will create a new +L<Moose::Meta::TypeConstraint::DuckType> object for that enum name. + +=item B<find_or_parse_type_constraint($type_name)> + +Given a type name, this first attempts to find a matching constraint +in the global registry. + +If the type name is a union or parameterized type, it will create a +new object of the appropriate, but if given a "regular" type that does +not yet exist, it simply returns false. + +When given a union or parameterized type, the member or base type must +already exist. + +If it creates a new union or parameterized type, it will add it to the +global registry. + +=item B<find_or_create_isa_type_constraint($type_name)> + +=item B<find_or_create_does_type_constraint($type_name)> + +These functions will first call C<find_or_parse_type_constraint>. If +that function does not return a type, a new type object will +be created. + +The C<isa> variant will use C<create_class_type_constraint> and the +C<does> variant will use C<create_role_type_constraint>. + +=item B<get_type_constraint_registry> + +Returns the L<Moose::Meta::TypeConstraint::Registry> object which +keeps track of all type constraints. + +=item B<list_all_type_constraints> + +This will return a list of type constraint names in the global +registry. You can then fetch the actual type object using +C<find_type_constraint($type_name)>. + +=item B<list_all_builtin_type_constraints> + +This will return a list of builtin type constraints, meaning those +which are defined in this module. See the L<Default Type Constraints> +section for a complete list. + +=item B<export_type_constraints_as_functions> + +This will export all the current type constraints as functions into +the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is +mostly used for testing, but it might prove useful to others. + +=item B<get_all_parameterizable_types> + +This returns all the parameterizable types that have been registered, +as a list of type objects. + +=item B<add_parameterizable_type($type)> + +Adds C<$type> to the list of parameterizable types + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Util/TypeConstraints/Builtins.pm b/lib/Moose/Util/TypeConstraints/Builtins.pm new file mode 100644 index 0000000..400afe6 --- /dev/null +++ b/lib/Moose/Util/TypeConstraints/Builtins.pm @@ -0,0 +1,305 @@ +package Moose::Util::TypeConstraints::Builtins; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::Load qw( is_class_loaded ); +use List::Util 1.33 (); +use Scalar::Util qw( blessed ); + +sub type { goto &Moose::Util::TypeConstraints::type } +sub subtype { goto &Moose::Util::TypeConstraints::subtype } +sub as { goto &Moose::Util::TypeConstraints::as } +sub where (&) { goto &Moose::Util::TypeConstraints::where } +sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as } + +sub define_builtins { + my $registry = shift; + + type 'Any' # meta-type including all + => where {1} + => inline_as { '1' }; + + subtype 'Item' # base type + => as 'Any' + => inline_as { '1' }; + + subtype 'Undef' + => as 'Item' + => where { !defined($_) } + => inline_as { + '!defined(' . $_[1] . ')' + }; + + subtype 'Defined' + => as 'Item' + => where { defined($_) } + => inline_as { + 'defined(' . $_[1] . ')' + }; + + subtype 'Bool' + => as 'Item' + => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' } + => inline_as { + '(' + . '!defined(' . $_[1] . ') ' + . '|| ' . $_[1] . ' eq "" ' + . '|| (' . $_[1] . '."") eq "1" ' + . '|| (' . $_[1] . '."") eq "0"' + . ')' + }; + + subtype 'Value' + => as 'Defined' + => where { !ref($_) } + => inline_as { + $_[0]->parent()->_inline_check($_[1]) + . ' && !ref(' . $_[1] . ')' + }; + + subtype 'Ref' + => as 'Defined' + => where { ref($_) } + # no need to call parent - ref also checks for definedness + => inline_as { 'ref(' . $_[1] . ')' }; + + subtype 'Str' + => as 'Value' + => where { ref(\$_) eq 'SCALAR' || ref(\(my $val = $_)) eq 'SCALAR' } + => inline_as { + $_[0]->parent()->_inline_check($_[1]) + . ' && (' + . 'ref(\\' . $_[1] . ') eq "SCALAR"' + . ' || ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR"' + . ')' + }; + + my $value_type = Moose::Util::TypeConstraints::find_type_constraint('Value'); + subtype 'Num' + => as 'Str' + => where { + my $val = $_; + ($val =~ /\A[+-]?[0-9]+\z/) || + ( $val =~ /\A(?:[+-]?) #matches optional +- in the beginning + (?=[0-9]|\.[0-9]) #matches previous +- only if there is something like 3 or .3 + [0-9]* #matches 0-9 zero or more times + (?:\.[0-9]+)? #matches optional .89 or nothing + (?:[Ee](?:[+-]?[0-9]+))? #matches E1 or e1 or e-1 or e+1 etc + \z/x ); + } + => inline_as { + # the long Str tests are redundant here + #storing $_[1] in a temporary value, + #so that $_[1] won't get converted to a string for regex match + #see t/attributes/numeric_defaults.t for more details + 'my $val = '.$_[1].';'. + $value_type->_inline_check('$val') + .' && ( $val =~ /\A[+-]?[0-9]+\z/ || ' + . '$val =~ /\A(?:[+-]?) #matches optional +- in the beginning + (?=[0-9]|\.[0-9]) #matches previous +- only if there is something like 3 or .3 + [0-9]* #matches 0-9 zero or more times + (?:\.[0-9]+)? #matches optional .89 or nothing + (?:[Ee](?:[+-]?[0-9]+))? #matches E1 or e1 or e-1 or e+1 etc + \z/x ); ' + }; + + subtype 'Int' + => as 'Num' + => where { (my $val = $_) =~ /\A-?[0-9]+\z/ } + => inline_as { + $value_type->_inline_check($_[1]) + . ' && (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/' + }; + + subtype 'CodeRef' + => as 'Ref' + => where { ref($_) eq 'CODE' } + => inline_as { 'ref(' . $_[1] . ') eq "CODE"' }; + + subtype 'RegexpRef' + => as 'Ref' + => where( \&_RegexpRef ) + => inline_as { + 'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')' + }; + + subtype 'GlobRef' + => as 'Ref' + => where { ref($_) eq 'GLOB' } + => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' }; + + # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a + # filehandle + subtype 'FileHandle' + => as 'Ref' + => where { + (ref($_) eq "GLOB" && Scalar::Util::openhandle($_)) + || (blessed($_) && $_->isa("IO::Handle")); + } + => inline_as { + '(ref(' . $_[1] . ') eq "GLOB" ' + . '&& Scalar::Util::openhandle(' . $_[1] . ')) ' + . '|| (Scalar::Util::blessed(' . $_[1] . ') ' + . '&& ' . $_[1] . '->isa("IO::Handle"))' + }; + + subtype 'Object' + => as 'Ref' + => where { blessed($_) } + => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' }; + + subtype 'ClassName' + => as 'Str' + => where { is_class_loaded($_) } + # the long Str tests are redundant here + => inline_as { 'Class::Load::is_class_loaded(' . $_[1] . ')' }; + + subtype 'RoleName' + => as 'ClassName' + => where { + (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role'); + } + => inline_as { + $_[0]->parent()->_inline_check($_[1]) + . ' && do {' + . 'my $meta = Class::MOP::class_of(' . $_[1] . ');' + . '$meta && $meta->isa("Moose::Meta::Role");' + . '}' + }; + + $registry->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'ScalarRef', + package_defined_in => __PACKAGE__, + parent => + Moose::Util::TypeConstraints::find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' }, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + return $check->( ${$_} ); + }; + }, + inlined => sub { + 'ref(' . $_[1] . ') eq "SCALAR" ' + . '|| ref(' . $_[1] . ') eq "REF"' + }, + inline_generator => sub { + my $self = shift; + my $type_parameter = shift; + my $val = shift; + '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") ' + . '&& ' . $type_parameter->_inline_check('${(' . $val . ')}') + }, + ) + ); + + $registry->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'ArrayRef', + package_defined_in => __PACKAGE__, + parent => + Moose::Util::TypeConstraints::find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'ARRAY' }, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + foreach my $x (@$_) { + ( $check->($x) ) || return; + } + 1; + } + }, + inlined => sub { 'ref(' . $_[1] . ') eq "ARRAY"' }, + inline_generator => sub { + my $self = shift; + my $type_parameter = shift; + my $val = shift; + + 'do {' + . 'my $check = ' . $val . ';' + . 'ref($check) eq "ARRAY" ' + . '&& &List::Util::all(' + . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, ' + . '@{$check}' + . ')' + . '}'; + }, + ) + ); + + $registry->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'HashRef', + package_defined_in => __PACKAGE__, + parent => + Moose::Util::TypeConstraints::find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'HASH' }, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + foreach my $x ( values %$_ ) { + ( $check->($x) ) || return; + } + 1; + } + }, + inlined => sub { 'ref(' . $_[1] . ') eq "HASH"' }, + inline_generator => sub { + my $self = shift; + my $type_parameter = shift; + my $val = shift; + + 'do {' + . 'my $check = ' . $val . ';' + . 'ref($check) eq "HASH" ' + . '&& &List::Util::all(' + . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, ' + . 'values %{$check}' + . ')' + . '}'; + }, + ) + ); + + $registry->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'Maybe', + package_defined_in => __PACKAGE__, + parent => + Moose::Util::TypeConstraints::find_type_constraint('Item'), + constraint => sub {1}, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + return 1 if not( defined($_) ) || $check->($_); + return; + } + }, + inlined => sub {'1'}, + inline_generator => sub { + my $self = shift; + my $type_parameter = shift; + my $val = shift; + '!defined(' . $val . ') ' + . '|| (' . $type_parameter->_inline_check($val) . ')' + }, + ) + ); +} + +1; + +__END__ + +=pod + +=for pod_coverage_needs_some_pod + +=cut diff --git a/lib/Test/Moose.pm b/lib/Test/Moose.pm new file mode 100644 index 0000000..a5aa4be --- /dev/null +++ b/lib/Test/Moose.pm @@ -0,0 +1,232 @@ +package Test::Moose; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Sub::Exporter; +use Test::Builder; + +use List::Util 1.33 'all'; +use Moose::Util 'does_role', 'find_meta'; + +my @exports = qw[ + meta_ok + does_ok + has_attribute_ok + with_immutable +]; + +Sub::Exporter::setup_exporter({ + exports => \@exports, + groups => { default => \@exports } +}); + +## the test builder instance ... + +my $Test = Test::Builder->new; + +## exported functions + +sub meta_ok ($;$) { + my ($class_or_obj, $message) = @_; + + $message ||= "The object has a meta"; + + if (find_meta($class_or_obj)) { + return $Test->ok(1, $message) + } + else { + return $Test->ok(0, $message); + } +} + +sub does_ok ($$;$) { + my ($class_or_obj, $does, $message) = @_; + + $message ||= "The object does $does"; + + if (does_role($class_or_obj, $does)) { + return $Test->ok(1, $message) + } + else { + return $Test->ok(0, $message); + } +} + +sub has_attribute_ok ($$;$) { + my ($class_or_obj, $attr_name, $message) = @_; + + $message ||= "The object does has an attribute named $attr_name"; + + my $meta = find_meta($class_or_obj); + + if ($meta->find_attribute_by_name($attr_name)) { + return $Test->ok(1, $message) + } + else { + return $Test->ok(0, $message); + } +} + +sub with_immutable (&@) { + my $block = shift; + my $before = $Test->current_test; + + $block->(0); + Class::MOP::class_of($_)->make_immutable for @_; + $block->(1); + + my $num_tests = $Test->current_test - $before; + my $all_passed = all { $_ } ($Test->summary)[-$num_tests..-1]; + return $all_passed; +} + +1; + +# ABSTRACT: Test functions for Moose specific features + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Moose - Test functions for Moose specific features + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Test::More plan => 1; + use Test::Moose; + + meta_ok($class_or_obj, "... Foo has a ->meta"); + does_ok($class_or_obj, $role, "... Foo does the Baz role"); + has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute"); + +=head1 DESCRIPTION + +This module provides some useful test functions for Moose based classes. It +is an experimental first release, so comments and suggestions are very welcome. + +=head1 EXPORTED FUNCTIONS + +=over 4 + +=item B<meta_ok ($class_or_object)> + +Tests if a class or object has a metaclass. + +=item B<does_ok ($class_or_object, $role, ?$message)> + +Tests if a class or object does a certain role, similar to what C<isa_ok> +does for the C<isa> method. + +=item B<has_attribute_ok($class_or_object, $attr_name, ?$message)> + +Tests if a class or object has a certain attribute, similar to what C<can_ok> +does for the methods. + +=item B<with_immutable { CODE } @class_names> + +Runs B<CODE> (which should contain normal tests) twice, and make each +class in C<@class_names> immutable in between the two runs. + +The B<CODE> block is called with a single boolean argument indicating whether +or not the classes have been made immutable yet. + +=back + +=head1 TODO + +=over 4 + +=item Convert the Moose test suite to use this module. + +=item Here is a list of possible functions to write + +=over 4 + +=item immutability predicates + +=item anon-class predicates + +=item discovering original method from modified method + +=item attribute metaclass predicates (attribute_isa?) + +=back + +=back + +=head1 SEE ALSO + +=over 4 + +=item L<Test::More> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/metaclass.pm b/lib/metaclass.pm new file mode 100644 index 0000000..366cf3d --- /dev/null +++ b/lib/metaclass.pm @@ -0,0 +1,155 @@ +package metaclass; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Module::Runtime 'use_package_optimistically', 'use_module'; +use Class::MOP; + +sub import { + my ( $class, @args ) = @_; + + unshift @args, "metaclass" if @args % 2 == 1; + my %options = @args; + + my $meta_name = exists $options{meta_name} ? $options{meta_name} : 'meta'; + my $metaclass = delete $options{metaclass}; + + unless ( defined $metaclass ) { + $metaclass = "Class::MOP::Class"; + } else { + use_package_optimistically($metaclass); + } + + ($metaclass->isa('Class::MOP::Class')) + || die use_module('Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass')->new( class_name => $metaclass ); + + # make sure the custom metaclasses get loaded + foreach my $key (grep { /_(?:meta)?class$/ } keys %options) { + unless ( ref( my $class = $options{$key} ) ) { + use_package_optimistically($class) + } + } + + my $package = caller(); + + # create a meta object so we can install &meta + my $meta = $metaclass->initialize($package => %options); + $meta->_add_meta_method($meta_name) + if defined $meta_name; +} + +1; + +# ABSTRACT: a pragma for installing and using Class::MOP metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +metaclass - a pragma for installing and using Class::MOP metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyClass; + + # use Class::MOP::Class + use metaclass; + + # ... or use a custom metaclass + use metaclass 'MyMetaClass'; + + # ... or use a custom metaclass + # and custom attribute and method + # metaclasses + use metaclass 'MyMetaClass' => ( + 'attribute_metaclass' => 'MyAttributeMetaClass', + 'method_metaclass' => 'MyMethodMetaClass', + ); + + # ... or just specify custom attribute + # and method classes, and Class::MOP::Class + # is the assumed metaclass + use metaclass ( + 'attribute_metaclass' => 'MyAttributeMetaClass', + 'method_metaclass' => 'MyMethodMetaClass', + ); + + # if we'd rather not install a 'meta' method, we can do this + use metaclass meta_name => undef; + # or if we'd like it to have a different name, + use metaclass meta_name => 'my_meta'; + +=head1 DESCRIPTION + +This is a pragma to make it easier to use a specific metaclass +and a set of custom attribute and method metaclasses. It also +installs a C<meta> method to your class as well, unless C<undef> +is passed to the C<meta_name> option. + +Note that if you are using Moose, you most likely do B<not> want +to be using this - look into L<Moose::Util::MetaRole> instead. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/oose.pm b/lib/oose.pm new file mode 100644 index 0000000..88cd407 --- /dev/null +++ b/lib/oose.pm @@ -0,0 +1,137 @@ +package oose; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); + +BEGIN { + my $package; + sub import { + $package = $_[1] || 'Class'; + if ($package =~ /^\+/) { + $package =~ s/^\+//; + Moose::Util::_load_user_class($package); + } + } + use Filter::Simple sub { s/^/package $package;\nuse Moose;use Moose::Util::TypeConstraints;\n/; } +} + +1; + +# ABSTRACT: syntactic sugar to make Moose one-liners easier + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +oose - syntactic sugar to make Moose one-liners easier + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + # create a Moose class on the fly ... + perl -Moose=Foo -e 'has bar => ( is=>q[ro], default => q[baz] ); print Foo->new->bar' # prints baz + + # loads an existing class (Moose or non-Moose) + # and re-"opens" the package definition to make + # debugging/introspection easier + perl -Moose=+My::Class -e 'print join ", " => __PACKAGE__->meta->get_method_list' + + # also loads Moose::Util::TypeConstraints to allow subtypes etc + perl -Moose=Person -e'subtype q[ValidAge] => as q[Int] => where { $_ > 0 && $_ < 78 }; has => age ( isa => q[ValidAge], is => q[ro]); Person->new(age => 90)' + +=head1 DESCRIPTION + +oose.pm is a simple source filter that adds +C<package $name; use Moose; use Moose::Util::TypeConstraints;> +to the beginning of your script and was entirely created because typing +C<perl -e'package Foo; use Moose; ...'> was annoying me. + +=head1 INTERFACE + +oose provides exactly one method and it's automatically called by perl: + +=over 4 + +=item B<import($package)> + +Pass a package name to import to be used by the source filter. The +package defaults to C<Class> if none is given. + +=back + +=head1 DEPENDENCIES + +You will need L<Filter::Simple> and eventually L<Moose> + +=head1 INCOMPATIBILITIES + +None reported. But it is a source filter and might have issues there. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut @@ -0,0 +1,286 @@ +#include "mop.h" + +void +mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark) +{ + dSP; + PUSHMARK(mark); + (*subaddr)(aTHX_ cv); + PUTBACK; +} + +#if PERL_VERSION >= 10 +UV +mop_check_package_cache_flag (pTHX_ HV *stash) +{ + assert(SvTYPE(stash) == SVt_PVHV); + + /* here we're trying to implement a c version of mro::get_pkg_gen($stash), + * however the perl core doesn't make it easy for us. It doesn't provide an + * api that just does what we want. + * + * However, we know that the information we want is, inside the core, + * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the + * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init, + * which is not public and only available inside the core, as the mro + * interface as well as the structure returned by mro_meta_init isn't + * considered to be stable yet. + * + * Perl_mro_meta_init isn't declared static, so we could just define it + * ourselfs if perls headers don't do that for us, except that won't work + * on platforms where symbols need to be explicitly exported when linking + * shared libraries. + * + * So our, hopefully temporary, solution is to be even more evil and + * basically reimplement HvMROMETA in a very fragile way that'll blow up + * when the relevant parts of the mro implementation in core change. + * + * :-( + * + */ + + return HvAUX(stash)->xhv_mro_meta + ? HvAUX(stash)->xhv_mro_meta->pkg_gen + : 0; +} + +#else /* pre 5.10.0 */ + +UV +mop_check_package_cache_flag (pTHX_ HV *stash) +{ + PERL_UNUSED_ARG(stash); + assert(SvTYPE(stash) == SVt_PVHV); + + return PL_sub_generation; +} +#endif + +SV * +mop_call0 (pTHX_ SV *const self, SV *const method) +{ + dSP; + SV *ret; + + PUSHMARK(SP); + XPUSHs(self); + PUTBACK; + + call_sv(method, G_SCALAR | G_METHOD); + + SPAGAIN; + ret = POPs; + PUTBACK; + + return ret; +} + +int +mop_get_code_info (SV *coderef, char **pkg, char **name) +{ + if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { + return 0; + } + + coderef = SvRV(coderef); + + /* sub is still being compiled */ + if (!CvGV(coderef)) { + return 0; + } + + /* I think this only gets triggered with a mangled coderef, but if + we hit it without the guard, we segfault. The slightly odd return + value strikes me as an improvement (mst) + */ + + if ( isGV_with_GP(CvGV(coderef)) ) { + GV *gv = CvGV(coderef); + HV *stash = GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef); + + *pkg = stash ? HvNAME(stash) : "__UNKNOWN__"; + *name = GvNAME( CvGV(coderef) ); + } else { + *pkg = "__UNKNOWN__"; + *name = "__ANON__"; + } + + return 1; +} + +/* XXX: eventually this should just use the implementation in Package::Stash */ +void +mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud) +{ + HE *he; + + (void)hv_iterinit(stash); + + if (filter == TYPE_FILTER_NONE) { + while ( (he = hv_iternext(stash)) ) { + STRLEN keylen; + const char *key = HePV(he, keylen); + if (!cb(key, keylen, HeVAL(he), ud)) { + return; + } + } + return; + } + + while ( (he = hv_iternext(stash)) ) { + GV * const gv = (GV*)HeVAL(he); + STRLEN keylen; + const char * const key = HePV(he, keylen); + SV *sv = NULL; + + if(isGV(gv)){ + switch (filter) { + case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; + case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; + case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; + case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; + case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; + default: + croak("Unknown type"); + } + } + /* expand the gv into a real typeglob if it + * contains stub functions or constants and we + * were asked to return CODE references */ + else if (filter == TYPE_FILTER_CODE) { + gv_init(gv, stash, key, keylen, GV_ADDMULTI); + sv = (SV *)GvCV(gv); + } + + if (sv) { + if (!cb(key, keylen, sv, ud)) { + return; + } + } + } +} + +static bool +collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud) +{ + HV *hash = (HV *)ud; + + if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) { + croak("failed to store symbol ref"); + } + + return TRUE; +} + +HV * +mop_get_all_package_symbols (HV *stash, type_filter_t filter) +{ + HV *ret = newHV (); + mop_get_package_symbols (stash, filter, collect_all_symbols, ret); + return ret; +} + +#define DECLARE_KEY(name) { #name, #name, NULL, 0 } +#define DECLARE_KEY_WITH_VALUE(name, value) { #name, value, NULL, 0 } + +/* the order of these has to match with those in mop.h */ +static struct { + const char *name; + const char *value; + SV *key; + U32 hash; +} prehashed_keys[key_last] = { + DECLARE_KEY(_expected_method_class), + DECLARE_KEY(ISA), + DECLARE_KEY(VERSION), + DECLARE_KEY(accessor), + DECLARE_KEY(associated_class), + DECLARE_KEY(associated_metaclass), + DECLARE_KEY(associated_methods), + DECLARE_KEY(attribute_metaclass), + DECLARE_KEY(attributes), + DECLARE_KEY(body), + DECLARE_KEY(builder), + DECLARE_KEY(clearer), + DECLARE_KEY(constructor_class), + DECLARE_KEY(constructor_name), + DECLARE_KEY(definition_context), + DECLARE_KEY(destructor_class), + DECLARE_KEY(immutable_trait), + DECLARE_KEY(init_arg), + DECLARE_KEY(initializer), + DECLARE_KEY(insertion_order), + DECLARE_KEY(instance_metaclass), + DECLARE_KEY(is_inline), + DECLARE_KEY(method_metaclass), + DECLARE_KEY(methods), + DECLARE_KEY(name), + DECLARE_KEY(package), + DECLARE_KEY(package_name), + DECLARE_KEY(predicate), + DECLARE_KEY(reader), + DECLARE_KEY(wrapped_method_metaclass), + DECLARE_KEY(writer), + DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"), + DECLARE_KEY_WITH_VALUE(_version, "-version"), + DECLARE_KEY(operator) +}; + +SV * +mop_prehashed_key_for (mop_prehashed_key_t key) +{ + return prehashed_keys[key].key; +} + +U32 +mop_prehashed_hash_for (mop_prehashed_key_t key) +{ + return prehashed_keys[key].hash; +} + +void +mop_prehash_keys () +{ + int i; + for (i = 0; i < key_last; i++) { + const char *value = prehashed_keys[i].value; + prehashed_keys[i].key = newSVpv(value, strlen(value)); + PERL_HASH(prehashed_keys[i].hash, value, strlen(value)); + } +} + +XS_EXTERNAL(mop_xs_simple_reader) +{ +#ifdef dVAR + dVAR; dXSARGS; +#else + dXSARGS; +#endif + register HE *he; + mop_prehashed_key_t key = (mop_prehashed_key_t)CvXSUBANY(cv).any_i32; + SV *self; + + if (items != 1) { + croak("expected exactly one argument"); + } + + self = ST(0); + + if (!SvROK(self)) { + croak("can't call %s as a class method", prehashed_keys[key].name); + } + + if (SvTYPE(SvRV(self)) != SVt_PVHV) { + croak("object is not a hashref"); + } + + if ((he = hv_fetch_ent((HV *)SvRV(self), prehashed_keys[key].key, 0, prehashed_keys[key].hash))) { + ST(0) = HeVAL(he); + } + else { + ST(0) = &PL_sv_undef; + } + + XSRETURN(1); +} + @@ -0,0 +1,109 @@ +#ifndef __MOP_H__ +#define __MOP_H__ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newRV_noinc +#define NEED_sv_2pv_flags +#define NEED_sv_2pv_nolen +#include "ppport.h" + +/* In theory, ExtUtils::ParseXS provide backcompat for this. However, the only + * available version doing that right now is 3.03_02, which is a dev release. We + * don't want to depend on dev releases, so we copy the code here. It should be + * removed once there's a stable ExtUtils::ParseXS version newer than 3.03_02. */ +#ifndef XS_EXTERNAL +# define XS_EXTERNAL XS +#endif + +#define MOP_CALL_BOOT(name) mop_call_xs(aTHX_ name, cv, mark); + +#ifndef XSPROTO +#define XSPROTO(name) XS_EXTERNAL(name) +#endif + +#ifndef CvISXSUB +#define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE) +#endif + +void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark); + +typedef enum { + KEY__expected_method_class, + KEY_ISA, + KEY_VERSION, + KEY_accessor, + KEY_associated_class, + KEY_associated_metaclass, + KEY_associated_methods, + KEY_attribute_metaclass, + KEY_attributes, + KEY_body, + KEY_builder, + KEY_clearer, + KEY_constructor_class, + KEY_constructor_name, + KEY_definition_context, + KEY_destructor_class, + KEY_immutable_trait, + KEY_init_arg, + KEY_initializer, + KEY_insertion_order, + KEY_instance_metaclass, + KEY_is_inline, + KEY_method_metaclass, + KEY_methods, + KEY_name, + KEY_package, + KEY_package_name, + KEY_predicate, + KEY_reader, + KEY_wrapped_method_metaclass, + KEY_writer, + KEY_package_cache_flag, + KEY__version, + KEY_operator, + key_last, +} mop_prehashed_key_t; + +#define KEY_FOR(name) mop_prehashed_key_for(KEY_ ##name) +#define HASH_FOR(name) mop_prehashed_hash_for(KEY_ ##name) + +void mop_prehash_keys (void); +SV *mop_prehashed_key_for (mop_prehashed_key_t key); +U32 mop_prehashed_hash_for (mop_prehashed_key_t key); + +#define INSTALL_SIMPLE_READER(klass, name) INSTALL_SIMPLE_READER_WITH_KEY(klass, name, name) +#define INSTALL_SIMPLE_READER_WITH_KEY(klass, name, key) \ + { \ + CV *cv = newXS("Class::MOP::" #klass "::" #name, mop_xs_simple_reader, __FILE__); \ + CvXSUBANY(cv).any_i32 = KEY_ ##key; \ + } + +XS_EXTERNAL(mop_xs_simple_reader); + +extern SV *mop_method_metaclass; +extern SV *mop_associated_metaclass; +extern SV *mop_wrap; + +UV mop_check_package_cache_flag(pTHX_ HV *stash); +int mop_get_code_info (SV *coderef, char **pkg, char **name); +SV *mop_call0(pTHX_ SV *const self, SV *const method); + +typedef enum { + TYPE_FILTER_NONE, + TYPE_FILTER_CODE, + TYPE_FILTER_ARRAY, + TYPE_FILTER_IO, + TYPE_FILTER_HASH, + TYPE_FILTER_SCALAR, +} type_filter_t; + +typedef bool (*get_package_symbols_cb_t) (const char *, STRLEN, SV *, void *); + +void mop_get_package_symbols(HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud); +HV *mop_get_all_package_symbols (HV *stash, type_filter_t filter); + +#endif diff --git a/perltidyrc b/perltidyrc new file mode 100644 index 0000000..09588c6 --- /dev/null +++ b/perltidyrc @@ -0,0 +1,21 @@ +-l=78 +-i=4 +-ci=4 +-se +-b +-bar +-boc +-vt=0 +-vtc=0 +-cti=0 +-pt=1 +-bt=1 +-sbt=1 +-bbt=1 +-nolq +-npro +-nsfs +--opening-hash-brace-right +--no-outdent-long-comments +--blank-lines-before-packages=0 +-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" diff --git a/ppport.h b/ppport.h new file mode 100644 index 0000000..2bad3ba --- /dev/null +++ b/ppport.h @@ -0,0 +1,7452 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.21 + + Automatically created by Devel::PPPort running under perl 5.018001. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.21 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.11.5. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F<ppport.h>. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagially add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions or variables will be marked C<explicit> in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C<static> or global +variants. + +For a C<static> function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C<DPPP_NAMESPACE> +macro. Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.21; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +BhkDISABLE||5.019003| +BhkENABLE||5.019003| +BhkENTRY_set||5.019003| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002|5.004050|p +Copy||5.004050| +CvPADLIST||5.008001| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvAV||| +GvCV||| +GvHV||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeUTF8||5.010001| +HeVAL||5.004000| +HvENAMELEN||5.015004| +HvENAMEUTF8||5.015004| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAMELEN||5.015004| +HvNAMEUTF8||5.015004| +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.019003| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002|5.004050|p +Move||5.004050| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.019002||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.004000||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.019002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.019002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.019002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.019002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.010000| +PERL_SYS_INIT||5.010000| +PERL_SYS_TERM||5.019003| +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.019002||p +PL_bufptr|5.019002||p +PL_check||5.006000| +PL_compiling|5.004050||p +PL_comppad_name||5.017004| +PL_comppad||5.008001| +PL_copline|5.019002||p +PL_curcop|5.004050||p +PL_curpad||5.005000| +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.019002||p +PL_expect|5.019002||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.019002||p +PL_in_my|5.019002||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.019002||p +PL_lex_stuff|5.019002||p +PL_linestr|5.019002||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005|5.009005|p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.019002||p +PL_rsfp|5.019002||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.019002||p +POP_MULTICALL||5.019003| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.019003| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PadARRAY||5.019003| +PadMAX||5.019003| +PadlistARRAY||5.019003| +PadlistMAX||5.019003| +PadlistNAMESARRAY||5.019003| +PadlistNAMESMAX||5.019003| +PadlistNAMES||5.019003| +PadlistREFCNT||5.017004| +PadnameIsOUR||| +PadnameIsSTATE||| +PadnameLEN||5.019003| +PadnameOURSTASH||| +PadnameOUTER||| +PadnamePV||5.019003| +PadnameSV||5.019003| +PadnameTYPE||| +PadnameUTF8||5.019003| +PadnamelistARRAY||5.019003| +PadnamelistMAX||5.019003| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +READ_XDIGIT||5.017006| +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_INVLIST||5.019002| +SVt_IV||| +SVt_NULL||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVFM||| +SVt_PVGV||| +SVt_PVHV||| +SVt_PVIO||| +SVt_PVIV||| +SVt_PVLV||| +SVt_PVMG||| +SVt_PVNV||| +SVt_PV||| +SVt_REGEXP||5.011000| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_ro||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen|5.013007||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec_NN||5.017007| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTHINKFIRST||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.019002||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +WIDEST_UTYPE|5.015004||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002|5.007001|p +XCPT_TRY_END|5.009002|5.004000|p +XCPT_TRY_START|5.009002|5.004000|p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.013004| +XS_EXTERNAL||5.019003| +XS_INTERNAL||5.019003| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.019003| +XopENABLE||5.019003| +XopENTRY_set||5.019003| +XopENTRY||5.019003| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_add_range_to_invlist||| +_append_range_to_invlist||| +_core_swash_init||| +_get_swash_invlist||| +_invlist_array_init||| +_invlist_contains_cp||| +_invlist_contents||| +_invlist_dump||| +_invlist_intersection_maybe_complement_2nd||| +_invlist_intersection||| +_invlist_invert_prop||| +_invlist_invert||| +_invlist_len||| +_invlist_populate_swatch||| +_invlist_search||| +_invlist_subtract||| +_invlist_union_maybe_complement_2nd||| +_invlist_union||| +_is_uni_FOO||5.017008| +_is_uni_perl_idcont||5.017008| +_is_uni_perl_idstart||5.017007| +_is_utf8_FOO||5.017008| +_is_utf8_mark||5.017008| +_is_utf8_perl_idcont||5.017008| +_is_utf8_perl_idstart||5.017007| +_new_invlist_C_array||| +_new_invlist||| +_pMY_CXT|5.007003||p +_swash_inversion_hash||| +_swash_to_invlist||| +_to_fold_latin1||| +_to_uni_fold_flags||5.013011| +_to_upper_title_latin1||| +_to_utf8_fold_flags||5.015006| +_to_utf8_lower_flags||5.015006| +_to_utf8_title_flags||5.015006| +_to_utf8_upper_flags||5.015006| +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.019002||p +aTHXR|5.019002||p +aTHX_|5.006000||p +aTHX|5.006000||p +aassign_common_vars||| +add_cp_to_invlist||| +add_data|||n +add_utf16_textfilter||| +addmad||| +adjust_size_and_find_bucket|||n +adjust_stack_on_leave||| +alloc_maybe_populate_EXACT||| +alloccopstash||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_is_enabled||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_madprops||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend_guts||| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_tindex||5.017009| +av_top_index||5.017009| +av_undef||| +av_unshift||| +ax|||n +bad_type_gv||| +bad_type_pv||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_uni|||n +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx||5.013005| +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_locale_boundary_crossing||| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +ckWARN|5.006000||p +ck_entersub_args_core||| +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +cl_and|||n +cl_anything|||n +cl_init|||n +cl_is_anything|||n +cl_or|||n +clear_placeholders||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +compute_EXACTish||| +convert||| +cop_fetch_label||5.015001| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cop_store_label||5.015001| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.019003| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +core_prototype||| +core_regclass_swash||| +coresub_op||| +could_it_be_a_POSIX_class||| +cr_textfilter||| +create_eval_scope||| +croak_memory_wrap||5.019003|n +croak_no_mem|||n +croak_no_modify||5.013003|n +croak_nocontext|||vn +croak_popstack|||n +croak_sv||5.013001| +croak_xs_usage||5.010001|n +croak|||v +csighandler||5.009003|n +curmad||| +current_re_engine||| +curse||| +custom_op_desc||5.007003| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len_flags||| +cv_clone_into||| +cv_clone||| +cv_const_sv_or_av||| +cv_const_sv||5.004000| +cv_dump||| +cv_forget_slab||| +cv_get_call_checker||5.013006| +cv_set_call_checker||5.013006| +cv_undef||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.019002||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +defelem_target||| +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_ncmp||| +do_oddball||| +do_op_dump||5.006000| +do_op_xmldump||| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pmop_dump||5.006000| +do_pmop_xmldump||| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +dump_all_perl||| +dump_all||5.006000| +dump_eval||5.006000| +dump_exec_pos||| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +finalize_optree||| +finalize_op||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_hash_subscript||| +find_in_my_stash||| +find_lexical_cv||| +find_runcv_where||| +find_runcv||5.008001| +find_rundefsv2||| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident_maybe_lex||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form_short_octal_warning||| +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_and_check_backslash_N_name||| +get_aux_mg||| +get_av|5.006000||p +get_context||5.006000|n +get_cvn_flags|5.009005||p +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_invlist_iter_addr||| +get_invlist_offset_addr||| +get_invlist_previous_index_addr||| +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +glob_assign_ref||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_bslash_N||| +grok_bslash_c||| +grok_bslash_o||| +grok_bslash_x||| +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_autoload_pvn||5.015004| +gv_autoload_pv||5.015004| +gv_autoload_sv||5.015004| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmeth_pv_autoload||5.015004| +gv_fetchmeth_pvn_autoload||5.015004| +gv_fetchmeth_pvn||5.015004| +gv_fetchmeth_pv||5.015004| +gv_fetchmeth_sv_autoload||5.015004| +gv_fetchmeth_sv||5.015004| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_pv_flags||5.015004| +gv_fetchmethod_pvn_flags||5.015004| +gv_fetchmethod_sv_flags||5.015004| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_pvn||5.015004| +gv_init_pv||5.015004| +gv_init_svtype||| +gv_init_sv||5.015004| +gv_init||| +gv_magicalize_isa||| +gv_name_set||5.009004| +gv_stashpvn|5.004000||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsv||| +gv_try_downgrade||| +handle_regex_sets||| +he_dup||| +hek_dup||| +hfree_next_entry||| +hfreeentries||| +hsplit||| +hv_assert||| +hv_auxinit||| +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_ent||5.004000| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent_ret||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.004000| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||| +hv_placeholders_set||5.009003| +hv_rand_set||5.017011| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_constants||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +inplace_aassign||| +instr|||n +intro_my||| +intuit_method||| +intuit_more||| +invert||| +invlist_array||| +invlist_clone||| +invlist_extend||| +invlist_highest||| +invlist_is_iterating||| +invlist_iterfinish||| +invlist_iterinit||| +invlist_iternext||| +invlist_max||| +invlist_previous_index||| +invlist_set_len||| +invlist_set_previous_index||| +invlist_trim||| +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALNUM_lazy||| +isALPHANUMERIC||5.017008| +isALPHA||| +isASCII|5.006000|5.006000|p +isBLANK|5.006001||p +isCNTRL|5.006000|5.006000|p +isDIGIT||| +isFOO_lc||| +isFOO_utf8_lc||| +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isIDCONT||5.017008| +isIDFIRST_lazy||| +isIDFIRST||| +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSPACE||| +isUPPER||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000|n +is_cur_LC_category_utf8||| +is_handle_constructor|||n +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.017007| +is_uni_alnumc||5.017007| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_blank_lc||5.017002| +is_uni_blank||5.017002| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.017007| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_blank||5.017002| +is_utf8_char_buf||5.015008|n +is_utf8_char_slow|||n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +mad_free||| +madlex||| +madparse||| +magic_clear_all_env||| +magic_cleararylen_p||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_copycallchecker||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie_failtable||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +matcher_matches_sv||| +mayberelocate||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess_sv||5.013001| +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find_mglob||| +mg_findext||5.013008| +mg_find||| +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +minus_v||| +missingterm||| +mode_from_discipline||| +modkids||| +more_bodies||| +more_sv||| +moreswitches||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_kid||| +my_lstat_flags||| +my_lstat||5.019003| +my_memcmp|||n +my_memset||5.004000|n +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.019003| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB_flags||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB_flags||5.015006| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen_flags||5.015004| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMADPROP||| +newMADsv||| +newMYSUB||5.017004| +newNULLLIST||| +newOP||| +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSTUB||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpadname||5.017004| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newTOKEN||| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_flags||5.009004| +newXS_len_flags||| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +not_incrementable||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_const_sv||| +op_contextualize||5.013006| +op_dump||5.006000| +op_free||| +op_getmad_weak||| +op_getmad||| +op_integerize||| +op_linklist||5.013006| +op_lvalue_flags||| +op_lvalue||5.013007| +op_null||5.007002| +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_scope||5.013007| +op_std_init||| +op_unscope||| +op_xmldump||| +open_script||| +opslab_force_free||| +opslab_free_nopad||| +opslab_free||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||5.008001| +pad_add_name_pvn||5.015001| +pad_add_name_pvs||5.015001| +pad_add_name_pv||5.015001| +pad_add_name_sv||5.015001| +pad_alloc_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||5.009003| +pad_findlex||| +pad_findmy_pvn||5.015001| +pad_findmy_pvs||5.015001| +pad_findmy_pv||5.015001| +pad_findmy_sv||5.015001| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||5.008001| +pad_peg|||n +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||5.008001| +padlist_dup||| +padlist_store||| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_ident||| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_lparen_question_flags||| +parse_stmtseq||5.013006| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free_nexttoke_ops||| +parser_free||| +path_is_searchable|||n +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmop_xmldump||| +pmruntime||| +pmtrans||| +pop_scope||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prepend_madprops||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_hash|||n +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_byte||| +put_latin1_charclass_innards||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.019001| +re_intuit_string||5.006000| +re_op_compile||| +readpipe_override||| +realloc||5.007002|n +reentrant_free||5.019003| +reentrant_init||5.019003| +reentrant_retry||5.019003|vn +reentrant_size||5.019003| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.019003| +reg_check_named_buff_matched||| +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment||| +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly||| +regdump_extflags||| +regdump_intflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regpatws|||n +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reguni||| +regwhite|||n +reg||| +repeatcpy|||n +report_evil_fh||| +report_redefined_cv||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem_flags||5.011000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic_flags||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +screaminstr||5.005000| +search_const||| +seed||5.008001| +sequence_num||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +share_hek_flags||| +share_hek||5.004000| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace0||| +skipspace1||| +skipspace2||| +skipspace_flags||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +stack_grow||| +start_force||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_catxmlpvn||| +sv_catxmlpv||| +sv_catxmlsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_copypv_flags||5.017002| +sv_copypv_nomg||5.017002| +sv_copypv||| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from_pvn||5.015004| +sv_derived_from_pv||5.015004| +sv_derived_from_sv||5.015004| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_display||| +sv_does_pvn||5.015004| +sv_does_pv||5.015004| +sv_does_sv||5.015004| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8_nomg||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.019003|5.004000|p +sv_magicext_mglob||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy_flags||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u_flags||5.019003| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_ref||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_resetpvn||| +sv_reset||| +sv_rvweaken||5.006000| +sv_sethek||| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.019003| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext||5.013008| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn_flags||5.017002| +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +sv_xmlpeek||| +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +swatch_get||| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow||5.006000| +toFOLD_uni||5.007003| +toFOLD_utf8||5.019001| +toFOLD||5.019001| +toLOWER_L1||5.019001| +toLOWER_LC||5.004000| +toLOWER_uni||5.007003| +toLOWER_utf8||5.015007| +toLOWER||| +toTITLE_uni||5.007003| +toTITLE_utf8||5.015007| +toTITLE||5.019001| +toUPPER_uni||5.007003| +toUPPER_utf8||5.015007| +toUPPER||5.004000| +to_byte_substr||| +to_lower_latin1||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.015007| +to_utf8_lower||5.015007| +to_utf8_substr||| +to_utf8_title||5.015007| +to_utf8_upper||5.015007| +token_free||| +token_getmad||| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments_pv||| +too_few_arguments_sv||| +too_many_arguments_pv||| +too_many_arguments_sv||| +translate_substr_offsets||| +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr_buf||5.015009| +utf8_to_uvchr||5.007001| +utf8_to_uvuni_buf||5.015009| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +valid_utf8_to_uvchr||| +valid_utf8_to_uvuni||5.015009| +validate_proto||| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warn_sv||5.013001| +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +was_lvalue_sub||| +watch||| +whichsig_pvn||5.015004| +whichsig_pv||5.015004| +whichsig_sv||5.015004| +whichsig||| +win32_croak_not_implemented|||n +with_queued_errors||| +wrap_op_checker||5.015008| +write_to_stderr||| +xmldump_all_perl||| +xmldump_all||| +xmldump_attr||| +xmldump_eval||| +xmldump_form||| +xmldump_indent|||v +xmldump_packsubs_perl||| +xmldump_packsubs||| +xmldump_sub_perl||| +xmldump_sub||| +xmldump_vindent||| +xs_apiversion_bootcheck||| +xs_version_bootcheck||| +yyerror_pvn||| +yyerror_pv||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while (<DATA>) { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef LONGSIZE +# define LONGSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef LONGSIZE +# define LONGSIZE 4 +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include <note.h> +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif + +#ifdef HAS_QUAD +# define WIDEST_UTYPE U64TYPE +#else +# define WIDEST_UTYPE U32 +#endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# elif IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# else +# error "cannot define IV/UV formats" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif + +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%"UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%"UVxf"}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..c6684f5 --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,199 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'Dist::CheckConflicts' => '0.02', + 'ExtUtils::CBuilder' => '0.27', + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0' + } + }, + 'develop' => { + 'requires' => { + 'Algorithm::C3' => '0', + 'Class::Load' => '0.07', + 'DBM::Deep' => '1.003', + 'Data::Visitor' => '0', + 'DateTime' => '0', + 'DateTime::Calendar::Mayan' => '0', + 'DateTime::Format::MySQL' => '0', + 'Declare::Constraints::Simple' => '0', + 'ExtUtils::MakeMaker::Dist::Zilla::Develop' => '0', + 'File::Find::Rule' => '0', + 'File::Spec' => '0', + 'HTTP::Headers' => '0', + 'IO::File' => '0', + 'IO::Handle' => '0', + 'IO::String' => '0', + 'IPC::Open3' => '0', + 'Locale::US' => '0', + 'Module::CPANTS::Analyse' => '0.92', + 'Module::Refresh' => '0', + 'MooseX::MarkAsMethods' => '0', + 'MooseX::NonMoose' => '0', + 'PadWalker' => '0', + 'Params::Coerce' => '0', + 'Regexp::Common' => '0', + 'SUPER' => '1.10', + 'Specio' => '0.10', + 'Test::CPAN::Changes' => '0.19', + 'Test::CPAN::Meta' => '0', + 'Test::Deep' => '0', + 'Test::EOL' => '0', + 'Test::Inline' => '0', + 'Test::Kwalitee' => '1.21', + 'Test::LeakTrace' => '0', + 'Test::Memory::Cycle' => '0', + 'Test::More' => '0.94', + 'Test::NoTabs' => '0', + 'Test::Output' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.04', + 'Test::Spelling' => '0', + 'URI' => '0', + 'blib' => '0' + }, + 'suggests' => { + 'CPAN::Meta::Requirements' => '0', + 'Carp' => '1.22', + 'Class::Load' => '0.09', + 'Class::Load::XS' => '0.01', + 'Data::OptList' => '0.107', + 'Devel::GlobalDestruction' => '0', + 'Devel::OverloadInfo' => '0.002', + 'Devel::StackTrace' => '1.33', + 'Dist::Zilla' => '5', + 'Dist::Zilla::Plugin::BumpVersionAfterRelease' => '0', + 'Dist::Zilla::Plugin::CheckChangesHasContent' => '0', + 'Dist::Zilla::Plugin::CheckVersionIncrement' => '0', + 'Dist::Zilla::Plugin::ConfirmRelease' => '0', + 'Dist::Zilla::Plugin::Conflicts' => '0.16', + 'Dist::Zilla::Plugin::CopyFilesFromRelease' => '0', + 'Dist::Zilla::Plugin::EnsurePrereqsInstalled' => '0.003', + 'Dist::Zilla::Plugin::ExecDir' => '0', + 'Dist::Zilla::Plugin::FileFinder::ByName' => '0', + 'Dist::Zilla::Plugin::FileFinder::Filter' => '0', + 'Dist::Zilla::Plugin::Git::Check' => '0', + 'Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch' => '0', + 'Dist::Zilla::Plugin::Git::Commit' => '0', + 'Dist::Zilla::Plugin::Git::Contributors' => '0', + 'Dist::Zilla::Plugin::Git::Describe' => '0.004', + 'Dist::Zilla::Plugin::Git::GatherDir' => '0', + 'Dist::Zilla::Plugin::Git::Push' => '0', + 'Dist::Zilla::Plugin::Git::Remote::Check' => '0', + 'Dist::Zilla::Plugin::Git::Tag' => '0', + 'Dist::Zilla::Plugin::License' => '0', + 'Dist::Zilla::Plugin::MakeMaker::Awesome' => '0', + 'Dist::Zilla::Plugin::Manifest' => '0', + 'Dist::Zilla::Plugin::MetaConfig' => '0', + 'Dist::Zilla::Plugin::MetaJSON' => '0', + 'Dist::Zilla::Plugin::MetaNoIndex' => '0', + 'Dist::Zilla::Plugin::MetaProvides::Package' => '1.15000002', + 'Dist::Zilla::Plugin::MetaResources' => '0', + 'Dist::Zilla::Plugin::MetaTests' => '0', + 'Dist::Zilla::Plugin::MetaYAML' => '0', + 'Dist::Zilla::Plugin::MojibakeTests' => '0', + 'Dist::Zilla::Plugin::NextRelease' => '5.033', + 'Dist::Zilla::Plugin::PodSyntaxTests' => '0', + 'Dist::Zilla::Plugin::Prereqs' => '0', + 'Dist::Zilla::Plugin::Prereqs::AuthorDeps' => '0', + 'Dist::Zilla::Plugin::PromptIfStale' => '0', + 'Dist::Zilla::Plugin::RewriteVersion' => '0', + 'Dist::Zilla::Plugin::Run::AfterRelease' => '0', + 'Dist::Zilla::Plugin::RunExtraTests' => '0', + 'Dist::Zilla::Plugin::ShareDir' => '0', + 'Dist::Zilla::Plugin::SurgicalPodWeaver' => '0.0023', + 'Dist::Zilla::Plugin::Test::CPAN::Changes' => '0', + 'Dist::Zilla::Plugin::Test::CheckBreaks' => '0', + 'Dist::Zilla::Plugin::Test::Compile' => '2.037', + 'Dist::Zilla::Plugin::Test::EOL' => '0.14', + 'Dist::Zilla::Plugin::Test::Kwalitee' => '0', + 'Dist::Zilla::Plugin::Test::NoTabs' => '0', + 'Dist::Zilla::Plugin::Test::ReportPrereqs' => '0', + 'Dist::Zilla::Plugin::TestRelease' => '0', + 'Dist::Zilla::Plugin::UploadToCPAN' => '0', + 'Dist::Zilla::Util::AuthorDeps' => '5.021', + 'Eval::Closure' => '0.04', + 'ExtUtils::CBuilder' => '0.27', + 'File::Find::Rule' => '0', + 'File::Spec' => '0', + 'File::pushd' => '0', + 'IPC::System::Simple' => '0', + 'List::MoreUtils' => '0.28', + 'List::Util' => '1.35', + 'MRO::Compat' => '0.05', + 'Module::Runtime' => '0.014', + 'Module::Runtime::Conflicts' => '0.002', + 'Package::DeprecationManager' => '0.11', + 'Package::Stash' => '0.32', + 'Package::Stash::XS' => '0.24', + 'Params::Util' => '1.00', + 'Path::Tiny' => '0', + 'Scalar::Util' => '1.19', + 'Sub::Exporter' => '0.980', + 'Sub::Identify' => '0', + 'Sub::Name' => '0.05', + 'Task::Weaken' => '0', + 'Test::Deep' => '0', + 'Test::Inline' => '0', + 'Test::Inline::Extract' => '0', + 'Try::Tiny' => '0.17', + 'parent' => '0.223', + 'perl' => 'v5.8.3', + 'strict' => '1.03', + 'warnings' => '1.03' + } + }, + 'runtime' => { + 'requires' => { + 'Carp' => '1.22', + 'Class::Load' => '0.09', + 'Class::Load::XS' => '0.01', + 'Data::OptList' => '0.107', + 'Devel::GlobalDestruction' => '0', + 'Devel::OverloadInfo' => '0.002', + 'Devel::StackTrace' => '1.33', + 'Dist::CheckConflicts' => '0.02', + 'Eval::Closure' => '0.04', + 'List::MoreUtils' => '0.28', + 'List::Util' => '1.35', + 'MRO::Compat' => '0.05', + 'Module::Runtime' => '0.014', + 'Module::Runtime::Conflicts' => '0.002', + 'Package::DeprecationManager' => '0.11', + 'Package::Stash' => '0.32', + 'Package::Stash::XS' => '0.24', + 'Params::Util' => '1.00', + 'Scalar::Util' => '1.19', + 'Sub::Exporter' => '0.980', + 'Sub::Identify' => '0', + 'Sub::Name' => '0.05', + 'Task::Weaken' => '0', + 'Try::Tiny' => '0.17', + 'parent' => '0.223', + 'perl' => 'v5.8.3', + 'strict' => '1.03', + 'warnings' => '1.03' + }, + 'suggests' => { + 'Devel::PartialDump' => '0.14' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'CPAN::Meta::Check' => '0.007', + 'CPAN::Meta::Requirements' => '0', + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'Test::CleanNamespaces' => '0.13', + 'Test::Fatal' => '0.001', + 'Test::More' => '0.88', + 'Test::Requires' => '0.05', + 'Test::Warnings' => '0.016' + } + } + }; + $x; + }
\ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..00a51cf --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,203 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.021 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + Algorithm::C3 + DBM::Deep + DateTime + DateTime::Calendar::Mayan + DateTime::Format::MySQL + Declare::Constraints::Simple + Dist::CheckConflicts + HTTP::Headers + IO::File + IO::String + Locale::US + Module::Refresh + MooseX::NonMoose + Params::Coerce + Regexp::Common + SUPER + Test::Deep + Test::DependentModules + Test::LeakTrace + Test::Output + URI +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do 't/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +if ( $source && $HAS_CPAN_META ) { + if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); + } +} +else { + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/000_load.t b/t/000_load.t new file mode 100644 index 0000000..afd9e9f --- /dev/null +++ b/t/000_load.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + use_ok('Moose'); +} + +done_testing; diff --git a/t/attributes/accessor_context.t b/t/attributes/accessor_context.t new file mode 100644 index 0000000..f07a499 --- /dev/null +++ b/t/attributes/accessor_context.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +is( exception { + package My::Class; + use Moose; + + has s_rw => ( + is => 'rw', + ); + + has s_ro => ( + is => 'ro', + ); + + has a_rw => ( + is => 'rw', + isa => 'ArrayRef', + + auto_deref => 1, + ); + + has a_ro => ( + is => 'ro', + isa => 'ArrayRef', + + auto_deref => 1, + ); + + has h_rw => ( + is => 'rw', + isa => 'HashRef', + + auto_deref => 1, + ); + + has h_ro => ( + is => 'ro', + isa => 'HashRef', + + auto_deref => 1, + ); +}, undef, 'class definition' ); + +is( exception { + my $o = My::Class->new(); + + is_deeply [scalar $o->s_rw], [undef], 'uninitialized scalar attribute/rw in scalar context'; + is_deeply [$o->s_rw], [undef], 'uninitialized scalar attribute/rw in list context'; + is_deeply [scalar $o->s_ro], [undef], 'uninitialized scalar attribute/ro in scalar context'; + is_deeply [$o->s_ro], [undef], 'uninitialized scalar attribute/ro in list context'; + + + is_deeply [scalar $o->a_rw], [undef], 'uninitialized ArrayRef attribute/rw in scalar context'; + is_deeply [$o->a_rw], [], 'uninitialized ArrayRef attribute/rw in list context'; + is_deeply [scalar $o->a_ro], [undef], 'uninitialized ArrayRef attribute/ro in scalar context'; + is_deeply [$o->a_ro], [], 'uninitialized ArrayRef attribute/ro in list context'; + + is_deeply [scalar $o->h_rw], [undef], 'uninitialized HashRef attribute/rw in scalar context'; + is_deeply [$o->h_rw], [], 'uninitialized HashRef attribute/rw in list context'; + is_deeply [scalar $o->h_ro], [undef], 'uninitialized HashRef attribute/ro in scalar context'; + is_deeply [$o->h_ro], [], 'uninitialized HashRef attribute/ro in list context'; + +}, undef, 'testing' ); + +done_testing; diff --git a/t/attributes/accessor_inlining.t b/t/attributes/accessor_inlining.t new file mode 100644 index 0000000..8212e53 --- /dev/null +++ b/t/attributes/accessor_inlining.t @@ -0,0 +1,32 @@ +use strict; +use warnings; +use Test::More; + +my $called; +{ + package Foo::Meta::Instance; + use Moose::Role; + + sub is_inlinable { 0 } + + after get_slot_value => sub { $called++ }; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['Foo::Meta::Instance'], + }, + ); + + has foo => (is => 'ro'); +} + +my $foo = Foo->new(foo => 1); +is($foo->foo, 1, "got the right value"); +is($called, 1, "reader was called"); + +done_testing; diff --git a/t/attributes/accessor_override_method.t b/t/attributes/accessor_override_method.t new file mode 100644 index 0000000..10343b9 --- /dev/null +++ b/t/attributes/accessor_override_method.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + + package Foo; + use Moose; + + sub get_a { } + sub set_b { } + sub has_c { } + sub clear_d { } + sub e { } + sub stub; +} + +my $foo_meta = Foo->meta; +stderr_like( + sub { $foo_meta->add_attribute( a => ( reader => 'get_a' ) ) }, + qr/^You are overwriting a locally defined method \(get_a\) with an accessor/, + 'reader overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( b => ( writer => 'set_b' ) ) }, + qr/^You are overwriting a locally defined method \(set_b\) with an accessor/, + 'writer overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( c => ( predicate => 'has_c' ) ) }, + qr/^You are overwriting a locally defined method \(has_c\) with an accessor/, + 'predicate overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( d => ( clearer => 'clear_d' ) ) }, + qr/^You are overwriting a locally defined method \(clear_d\) with an accessor/, + 'clearer overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( e => ( is => 'rw' ) ) }, + qr/^You are overwriting a locally defined method \(e\) with an accessor/, + 'accessor overriding gives proper warning' +); +stderr_is( + sub { $foo_meta->add_attribute( stub => ( is => 'rw' ) ) }, + q{}, + 'overriding a stub with an accessor does not warn' +); +stderr_like( + sub { $foo_meta->add_attribute( has => ( is => 'rw' ) ) }, + qr/^You are overwriting a locally defined function \(has\) with an accessor/, + 'function overriding gives proper warning' +); + +done_testing; diff --git a/t/attributes/accessor_overwrite_warning.t b/t/attributes/accessor_overwrite_warning.t new file mode 100644 index 0000000..aa659f7 --- /dev/null +++ b/t/attributes/accessor_overwrite_warning.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; + +use Test::Requires 'Test::Output'; + +{ + package Bar; + use Moose; + + has has_attr => ( + is => 'ro', + ); + + ::stderr_like{ has attr => ( + is => 'ro', + predicate => 'has_attr', + ) + } + qr/\QYou are overwriting an accessor (has_attr) for the has_attr attribute with a new accessor method for the attr attribute/, + 'overwriting an accessor for another attribute causes a warning'; +} + +done_testing; diff --git a/t/attributes/attr_dereference_test.t b/t/attributes/attr_dereference_test.t new file mode 100644 index 0000000..1aeea9c --- /dev/null +++ b/t/attributes/attr_dereference_test.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Customer; + use Moose; + + package Firm; + use Moose; + use Moose::Util::TypeConstraints; + + ::is( ::exception { + has 'customers' => ( + is => 'ro', + isa => subtype('ArrayRef' => where { + (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }), + auto_deref => 1, + ); + }, undef, '... successfully created attr' ); +} + +{ + my $customer = Customer->new; + isa_ok($customer, 'Customer'); + + my $firm = Firm->new(customers => [ $customer ]); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [ $customer ], + '... got the right dereferenced value' + ); +} + +{ + my $firm = Firm->new(); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [], + '... got the right dereferenced value' + ); +} + +{ + package AutoDeref; + use Moose; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayRef[Int]', + auto_deref => 1, + ); +} + +{ + my $autoderef = AutoDeref->new; + + isnt( exception { + $autoderef->bar(1, 2, 3); + }, undef, '... its auto-de-ref-ing, not auto-en-ref-ing' ); + + is( exception { + $autoderef->bar([ 1, 2, 3 ]) + }, undef, '... set the results of bar correctly' ); + + is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly'; +} + +done_testing; diff --git a/t/attributes/attribute_accessor_generation.t b/t/attributes/attribute_accessor_generation.t new file mode 100644 index 0000000..e72ea7d --- /dev/null +++ b/t/attributes/attribute_accessor_generation.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util 'isweak'; + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + accessor => 'foo', + ); + }; + ::ok(!$@, '... created the accessor method okay'); + + eval { + has 'lazy_foo' => ( + accessor => 'lazy_foo', + lazy => 1, + default => sub { 10 } + ); + }; + ::ok(!$@, '... created the lazy accessor method okay'); + + + eval { + has 'foo_required' => ( + accessor => 'foo_required', + required => 1, + ); + }; + ::ok(!$@, '... created the required accessor method okay'); + + eval { + has 'foo_int' => ( + accessor => 'foo_int', + isa => 'Int', + ); + }; + ::ok(!$@, '... created the accessor method with type constraint okay'); + + eval { + has 'foo_weak' => ( + accessor => 'foo_weak', + weak_ref => 1 + ); + }; + ::ok(!$@, '... created the accessor method with weak_ref okay'); + + eval { + has 'foo_deref' => ( + accessor => 'foo_deref', + isa => 'ArrayRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the accessor method with auto_deref okay'); + + eval { + has 'foo_deref_ro' => ( + reader => 'foo_deref_ro', + isa => 'ArrayRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the reader method with auto_deref okay'); + + eval { + has 'foo_deref_hash' => ( + accessor => 'foo_deref_hash', + isa => 'HashRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the reader method with auto_deref okay'); +} + +{ + my $foo = Foo->new(foo_required => 'required'); + isa_ok($foo, 'Foo'); + + # regular accessor + + can_ok($foo, 'foo'); + is($foo->foo(), undef, '... got an unset value'); + is( exception { + $foo->foo(100); + }, undef, '... foo wrote successfully' ); + is($foo->foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + isnt( exception { + Foo->new; + }, undef, '... cannot create without the required attribute' ); + + can_ok($foo, 'foo_required'); + is($foo->foo_required(), 'required', '... got an unset value'); + is( exception { + $foo->foo_required(100); + }, undef, '... foo_required wrote successfully' ); + is($foo->foo_required(), 100, '... got the correct set value'); + + is( exception { + $foo->foo_required(undef); + }, undef, '... foo_required did not die with undef' ); + + is($foo->foo_required, undef, "value is undef"); + + ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); + + # lazy + + ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot'); + + can_ok($foo, 'lazy_foo'); + is($foo->lazy_foo(), 10, '... got an deferred value'); + + # with type constraint + + can_ok($foo, 'foo_int'); + is($foo->foo_int(), undef, '... got an unset value'); + is( exception { + $foo->foo_int(100); + }, undef, '... foo_int wrote successfully' ); + is($foo->foo_int(), 100, '... got the correct set value'); + + isnt( exception { + $foo->foo_int("Foo"); + }, undef, '... foo_int died successfully' ); + + ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); + + # with weak_ref + + my $test = []; + + can_ok($foo, 'foo_weak'); + is($foo->foo_weak(), undef, '... got an unset value'); + is( exception { + $foo->foo_weak($test); + }, undef, '... foo_weak wrote successfully' ); + is($foo->foo_weak(), $test, '... got the correct set value'); + + ok(isweak($foo->{foo_weak}), '... it is a weak reference'); + + can_ok( $foo, 'foo_deref'); + is_deeply( [$foo->foo_deref()], [], '... default default value'); + my @list; + is( exception { + @list = $foo->foo_deref(); + }, undef, "... doesn't deref undef value" ); + is_deeply( \@list, [], "returns empty list in list context"); + + is( exception { + $foo->foo_deref( [ qw/foo bar gorch/ ] ); + }, undef, '... foo_deref wrote successfully' ); + + is( Scalar::Util::reftype( scalar $foo->foo_deref() ), "ARRAY", "returns an array reference in scalar context" ); + is_deeply( scalar($foo->foo_deref()), [ qw/foo bar gorch/ ], "correct array" ); + + is( scalar( () = $foo->foo_deref() ), 3, "returns list in list context" ); + is_deeply( [ $foo->foo_deref() ], [ qw/foo bar gorch/ ], "correct list" ); + + + can_ok( $foo, 'foo_deref' ); + is_deeply( [$foo->foo_deref_ro()], [], "... default default value" ); + + isnt( exception { + $foo->foo_deref_ro( [] ); + }, undef, "... read only" ); + + $foo->{foo_deref_ro} = [qw/la la la/]; + + is_deeply( scalar($foo->foo_deref_ro()), [qw/la la la/], "scalar context ro" ); + is_deeply( [ $foo->foo_deref_ro() ], [qw/la la la/], "list context ro" ); + + can_ok( $foo, 'foo_deref_hash' ); + is_deeply( { $foo->foo_deref_hash() }, {}, "... default default value" ); + + my %hash; + is( exception { + %hash = $foo->foo_deref_hash(); + }, undef, "... doesn't deref undef value" ); + is_deeply( \%hash, {}, "returns empty list in list context"); + + is( exception { + $foo->foo_deref_hash( { foo => 1, bar => 2 } ); + }, undef, '... foo_deref_hash wrote successfully' ); + + is_deeply( scalar($foo->foo_deref_hash), { foo => 1, bar => 2 }, "scalar context" ); + + %hash = $foo->foo_deref_hash; + is_deeply( \%hash, { foo => 1, bar => 2 }, "list context"); +} + +done_testing; diff --git a/t/attributes/attribute_custom_metaclass.t b/t/attributes/attribute_custom_metaclass.t new file mode 100644 index 0000000..2778de5 --- /dev/null +++ b/t/attributes/attribute_custom_metaclass.t @@ -0,0 +1,90 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo::Meta::Attribute; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my $self = shift; + my $name = shift; + $next->($self, $name, (is => 'rw', isa => 'Foo'), @_); + }; + + package Foo; + use Moose; + + has 'foo' => (metaclass => 'Foo::Meta::Attribute'); +} +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $foo_attr = Foo->meta->get_attribute('foo'); + isa_ok($foo_attr, 'Foo::Meta::Attribute'); + isa_ok($foo_attr, 'Moose::Meta::Attribute'); + + is($foo_attr->name, 'foo', '... got the right name for our meta-attribute'); + ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us'); + + ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us'); + + my $foo_attr_type_constraint = $foo_attr->type_constraint; + isa_ok($foo_attr_type_constraint, 'Moose::Meta::TypeConstraint'); + + is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name'); + is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type constraint parent name'); +} +{ + package Bar::Meta::Attribute; + use Moose; + + extends 'Class::MOP::Attribute'; + + package Bar; + use Moose; + + ::is( ::exception { + has 'bar' => (metaclass => 'Bar::Meta::Attribute'); + }, undef, '... the attribute metaclass need not be a Moose::Meta::Attribute as long as it behaves' ); +} + +{ + package Moose::Meta::Attribute::Custom::Foo; + sub register_implementation { 'Foo::Meta::Attribute' } + + package Moose::Meta::Attribute::Custom::Bar; + use Moose; + + extends 'Moose::Meta::Attribute'; + + package Another::Foo; + use Moose; + + ::is( ::exception { + has 'foo' => (metaclass => 'Foo'); + }, undef, '... the attribute metaclass alias worked correctly' ); + + ::is( ::exception { + has 'bar' => (metaclass => 'Bar', is => 'bare'); + }, undef, '... the attribute metaclass alias worked correctly' ); +} + +{ + my $foo_attr = Another::Foo->meta->get_attribute('foo'); + isa_ok($foo_attr, 'Foo::Meta::Attribute'); + isa_ok($foo_attr, 'Moose::Meta::Attribute'); + + my $bar_attr = Another::Foo->meta->get_attribute('bar'); + isa_ok($bar_attr, 'Moose::Meta::Attribute::Custom::Bar'); + isa_ok($bar_attr, 'Moose::Meta::Attribute'); +} + +done_testing; diff --git a/t/attributes/attribute_delegation.t b/t/attributes/attribute_delegation.t new file mode 100644 index 0000000..3c61edd --- /dev/null +++ b/t/attributes/attribute_delegation.t @@ -0,0 +1,483 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +# ------------------------------------------------------------------- +# HASH handles +# ------------------------------------------------------------------- +# the canonical form of of the 'handles' +# option is the hash ref mapping a +# method name to the delegated method name + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', default => 10); + + sub baz { 42 } + + package Bar; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo->new }, + handles => { + 'foo_bar' => 'bar', + foo_baz => 'baz', + 'foo_bar_to_20' => [ bar => 20 ], + }, + ); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +ok($bar->foo, '... we have something in bar->foo'); +isa_ok($bar->foo, 'Foo'); + +my $meth = Bar->meta->get_method('foo_bar'); +isa_ok($meth, 'Moose::Meta::Method::Delegation'); +is($meth->associated_attribute->name, 'foo', + 'associated_attribute->name for this method is foo'); + +is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); + +can_ok($bar, 'foo_bar'); +is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); + +# change the value ... + +$bar->foo->bar(30); + +# and make sure the delegation picks it up + +is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + +# change the value through the delegation ... + +$bar->foo_bar(50); + +# and make sure everyone sees it + +is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + +# change the object we are delegating too + +my $foo = Foo->new(bar => 25); +isa_ok($foo, 'Foo'); + +is($foo->bar, 25, '... got the right foo->bar'); + +is( exception { + $bar->foo($foo); +}, undef, '... assigned the new Foo to Bar->foo' ); + +is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + +is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); +is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); + +# curried handles +$bar->foo_bar_to_20; +is($bar->foo_bar, 20, '... correctly curried a single argument'); + +# ------------------------------------------------------------------- +# ARRAY handles +# ------------------------------------------------------------------- +# we also support an array based format +# which assumes that the name is the same +# on either end + +{ + package Engine; + use Moose; + + sub go { 'Engine::go' } + sub stop { 'Engine::stop' } + + package Car; + use Moose; + + has 'engine' => ( + is => 'rw', + default => sub { Engine->new }, + handles => [ 'go', 'stop' ] + ); +} + +my $car = Car->new; +isa_ok($car, 'Car'); + +isa_ok($car->engine, 'Engine'); +can_ok($car->engine, 'go'); +can_ok($car->engine, 'stop'); + +is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); +is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); + +can_ok($car, 'go'); +can_ok($car, 'stop'); + +is($car->go, 'Engine::go', '... got the right value from ->go'); +is($car->stop, 'Engine::stop', '... got the right value from ->stop'); + +# ------------------------------------------------------------------- +# REGEXP handles +# ------------------------------------------------------------------- +# and we support regexp delegation + +{ + package Baz; + use Moose; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub boo { 'Baz::boo' } + + package Baz::Proxy1; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.*/ + ); + + package Baz::Proxy2; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.oo/ + ); + + package Baz::Proxy3; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/b.*/ + ); +} + +{ + my $baz_proxy = Baz::Proxy1->new; + isa_ok($baz_proxy, 'Baz::Proxy1'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy2->new; + isa_ok($baz_proxy, 'Baz::Proxy2'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy3->new; + isa_ok($baz_proxy, 'Baz::Proxy3'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} + +# ------------------------------------------------------------------- +# ROLE handles +# ------------------------------------------------------------------- + +{ + package Foo::Bar; + use Moose::Role; + + requires 'foo'; + requires 'bar'; + + package Foo::Baz; + use Moose; + + sub foo { 'Foo::Baz::FOO' } + sub bar { 'Foo::Baz::BAR' } + sub baz { 'Foo::Baz::BAZ' } + + package Foo::Thing; + use Moose; + + has 'thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => 'Foo::Bar', + ); + + package Foo::OtherThing; + use Moose; + use Moose::Util::TypeConstraints; + + has 'other_thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => Moose::Util::TypeConstraints::find_type_constraint('Foo::Bar'), + ); +} + +{ + my $foo = Foo::Thing->new(thing => Foo::Baz->new); + isa_ok($foo, 'Foo::Thing'); + isa_ok($foo->thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} + +{ + my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new); + isa_ok($foo, 'Foo::OtherThing'); + isa_ok($foo->other_thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} +# ------------------------------------------------------------------- +# AUTOLOAD & handles +# ------------------------------------------------------------------- + +{ + package Foo::Autoloaded; + use Moose; + + sub AUTOLOAD { + my $self = shift; + + my $name = our $AUTOLOAD; + $name =~ s/.*://; # strip fully-qualified portion + + if (@_) { + return $self->{$name} = shift; + } else { + return $self->{$name}; + } + } + + package Bar::Autoloaded; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => { 'foo_bar' => 'bar' } + ); + + package Baz::Autoloaded; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => ['bar'] + ); + + package Goorch::Autoloaded; + use Moose; + + ::isnt( ::exception { + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => qr/bar/ + ); + }, undef, '... you cannot delegate to AUTOLOADED class with regexp' ); +} + +# check HASH based delegation w/ AUTOLOAD + +{ + my $bar = Bar::Autoloaded->new; + isa_ok($bar, 'Bar::Autoloaded'); + + ok($bar->foo, '... we have something in bar->foo'); + isa_ok($bar->foo, 'Foo::Autoloaded'); + + # change the value ... + + $bar->foo->bar(30); + + # and make sure the delegation picks it up + + is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $bar->foo_bar(50); + + # and make sure everyone sees it + + is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + is( exception { + $bar->foo($foo); + }, undef, '... assigned the new Foo to Bar->foo' ); + + is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + + is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); + is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); +} + +# check ARRAY based delegation w/ AUTOLOAD + +{ + my $baz = Baz::Autoloaded->new; + isa_ok($baz, 'Baz::Autoloaded'); + + ok($baz->foo, '... we have something in baz->foo'); + isa_ok($baz->foo, 'Foo::Autoloaded'); + + # change the value ... + + $baz->foo->bar(30); + + # and make sure the delegation picks it up + + is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 30, '... baz->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $baz->bar(50); + + # and make sure everyone sees it + + is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 50, '... baz->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + is( exception { + $baz->foo($foo); + }, undef, '... assigned the new Foo to Baz->foo' ); + + is($baz->foo, $foo, '... assigned baz->foo with the new Foo'); + + is($baz->foo->bar, 25, '... baz->foo->bar returned the right result'); + is($baz->bar, 25, '... and baz->foo_bar delegated correctly again'); +} + +# Check that removing attributes removes their handles methods also. +{ + { + package Quux; + use Moose; + has foo => ( + isa => 'Foo', + default => sub { Foo->new }, + handles => { 'foo_bar' => 'bar' } + ); + } + my $i = Quux->new; + ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present'); + $i->meta->remove_attribute('foo'); + ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed'); +} + +# Make sure that a useful error message is thrown when the delegation target is +# not an object +{ + my $i = Bar->new(foo => undef); + like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' ); + + my $j = Bar->new(foo => []); + like( exception { $j->foo_bar }, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' ); + + my $k = Bar->new(foo => "Foo"); + is( exception { $k->foo_baz }, undef, "but not for class name" ); +} + +{ + package Delegator; + use Moose; + + sub full { 1 } + sub stub; + + ::like( + ::exception{ has d1 => ( + isa => 'X', + handles => ['full'], + ); + }, + qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, + 'got an error when trying to declare a delegation method that overwrites a local method' + ); + + ::is( + ::exception{ has d2 => ( + isa => 'X', + handles => ['stub'], + ); + }, + undef, + 'no error when trying to declare a delegation method that overwrites a stub method' + ); +} + +done_testing; diff --git a/t/attributes/attribute_does.t b/t/attributes/attribute_does.t new file mode 100644 index 0000000..32279a5 --- /dev/null +++ b/t/attributes/attribute_does.t @@ -0,0 +1,99 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo::Role; + use Moose::Role; + use Moose::Util::TypeConstraints; + + # if does() exists on its own, then + # we create a type constraint for + # it, just as we do for isa() + has 'bar' => (is => 'rw', does => 'Bar::Role'); + has 'baz' => ( + is => 'rw', + does => role_type('Bar::Role') + ); + + package Foo::Class; + use Moose; + + with 'Foo::Role'; + + package Bar::Role; + use Moose::Role; + + # if isa and does appear together, then see if Class->does(Role) + # if it does work... then the does() check is actually not needed + # since the isa() check will imply the does() check + has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role'); + + package Bar::Class; + use Moose; + + with 'Bar::Role'; +} + +my $foo = Foo::Class->new; +isa_ok($foo, 'Foo::Class'); + +my $bar = Bar::Class->new; +isa_ok($bar, 'Bar::Class'); + +is( exception { + $foo->bar($bar); +}, undef, '... bar passed the type constraint okay' ); + +isnt( exception { + $foo->bar($foo); +}, undef, '... foo did not pass the type constraint okay' ); + +is( exception { + $foo->baz($bar); +}, undef, '... baz passed the type constraint okay' ); + +isnt( exception { + $foo->baz($foo); +}, undef, '... foo did not pass the type constraint okay' ); + +is( exception { + $bar->foo($foo); +}, undef, '... foo passed the type constraint okay' ); + + + +# some error conditions + +{ + package Baz::Class; + use Moose; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::isnt( ::exception { + has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class'); + }, undef, '... cannot have a does() which is not done by the isa()' ); +} + +{ + package Bling; + use strict; + use warnings; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::isnt( ::exception { + has 'foo' => (isa => 'Bling', does => 'Bar::Class'); + }, undef, '... cannot have a isa() which is cannot does()' ); +} + +done_testing; diff --git a/t/attributes/attribute_inherited_slot_specs.t b/t/attributes/attribute_inherited_slot_specs.t new file mode 100644 index 0000000..2556e9a --- /dev/null +++ b/t/attributes/attribute_inherited_slot_specs.t @@ -0,0 +1,269 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Thing::Meta::Attribute; + use Moose; + + extends 'Moose::Meta::Attribute'; + around illegal_options_for_inheritance => sub { + return (shift->(@_), qw/trigger/); + }; + + package Thing; + use Moose; + + sub hello { 'Hello World (from Thing)' } + sub goodbye { 'Goodbye World (from Thing)' } + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'FooStr' + => as 'Str' + => where { /Foo/ }; + + coerce 'FooStr' + => from ArrayRef + => via { 'FooArrayRef' }; + + has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar'); + has 'baz' => (is => 'rw', isa => 'Ref'); + has 'foo' => (is => 'rw', isa => 'FooStr'); + + has 'gorch' => (is => 'ro'); + has 'gloum' => (is => 'ro', default => sub {[]}); + has 'fleem' => (is => 'ro'); + + has 'bling' => (is => 'ro', isa => 'Thing'); + has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']); + + has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef'); + + has 'one_last_one' => (is => 'rw', isa => 'Ref'); + + # this one will work here .... + has 'fail' => (isa => 'CodeRef', is => 'bare'); + has 'other_fail' => (metaclass => 'Thing::Meta::Attribute', is => 'bare', trigger => sub { }); + + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Foo'; + + ::is( ::exception { + has '+bar' => (default => 'Bar::bar'); + }, undef, '... we can change the default attribute option' ); + + ::is( ::exception { + has '+baz' => (isa => 'ArrayRef'); + }, undef, '... we can add change the isa as long as it is a subtype' ); + + ::is( ::exception { + has '+foo' => (coerce => 1); + }, undef, '... we can change/add coerce as an attribute option' ); + + ::is( ::exception { + has '+gorch' => (required => 1); + }, undef, '... we can change/add required as an attribute option' ); + + ::is( ::exception { + has '+gloum' => (lazy => 1); + }, undef, '... we can change/add lazy as an attribute option' ); + + ::is( ::exception { + has '+fleem' => (lazy_build => 1); + }, undef, '... we can add lazy_build as an attribute option' ); + + ::is( ::exception { + has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]'); + }, undef, '... extend an attribute with parameterized type' ); + + ::is( ::exception { + has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' })); + }, undef, '... extend an attribute with anon-subtype' ); + + ::is( ::exception { + has '+one_last_one' => (isa => 'Value'); + }, undef, '... now can extend an attribute with a non-subtype' ); + + ::is( ::exception { + has '+fleem' => (weak_ref => 1); + }, undef, '... now allowed to add the weak_ref option via inheritance' ); + + ::is( ::exception { + has '+bling' => (handles => ['hello']); + }, undef, '... we can add the handles attribute option' ); + + # this one will *not* work here .... + ::isnt( ::exception { + has '+blang' => (handles => ['hello']); + }, undef, '... we can not alter the handles attribute option' ); + ::is( ::exception { + has '+fail' => (isa => 'Ref'); + }, undef, '... can now create an attribute with an improper subtype relation' ); + ::isnt( ::exception { + has '+other_fail' => (trigger => sub {}); + }, undef, '... cannot create an attribute with an illegal option' ); + ::like( ::exception { + has '+does_not_exist' => (isa => 'Str'); + }, qr/in Bar/, '... cannot extend a non-existing attribute' ); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->foo, undef, '... got the right undef default value'); +is( exception { $foo->foo('FooString') }, undef, '... assigned foo correctly' ); +is($foo->foo, 'FooString', '... got the right value for foo'); + +isnt( exception { $foo->foo([]) }, undef, '... foo is not coercing (as expected)' ); + +is($foo->bar, 'Foo::bar', '... got the right default value'); +isnt( exception { $foo->bar(10) }, undef, '... Foo::bar is a read/only attr' ); + +is($foo->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + is( exception { $foo->baz($hash_ref) }, undef, '... Foo::baz accepts hash refs' ); + is($foo->baz, $hash_ref, '... got the right value assigned to baz'); + + my $array_ref = []; + is( exception { $foo->baz($array_ref) }, undef, '... Foo::baz accepts an array ref' ); + is($foo->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + is( exception { $foo->baz($scalar_ref) }, undef, '... Foo::baz accepts scalar ref' ); + is($foo->baz, $scalar_ref, '... got the right value assigned to baz'); + + is( exception { $foo->bunch_of_stuff([qw[one two three]]) }, undef, '... Foo::bunch_of_stuff accepts an array of strings' ); + + is( exception { $foo->one_last_one(sub { 'Hello World'}) }, undef, '... Foo::one_last_one accepts a code ref' ); + + my $code_ref = sub { 1 }; + is( exception { $foo->baz($code_ref) }, undef, '... Foo::baz accepts a code ref' ); + is($foo->baz, $code_ref, '... got the right value assigned to baz'); +} + +isnt( exception { + Bar->new; +}, undef, '... cannot create Bar without required gorch param' ); + +my $bar = Bar->new(gorch => 'Bar::gorch'); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo, undef, '... got the right undef default value'); +is( exception { $bar->foo('FooString') }, undef, '... assigned foo correctly' ); +is($bar->foo, 'FooString', '... got the right value for foo'); +is( exception { $bar->foo([]) }, undef, '... assigned foo correctly' ); +is($bar->foo, 'FooArrayRef', '... got the right value for foo'); + +is($bar->gorch, 'Bar::gorch', '... got the right default value'); + +is($bar->bar, 'Bar::bar', '... got the right default value'); +isnt( exception { $bar->bar(10) }, undef, '... Bar::bar is a read/only attr' ); + +is($bar->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + isnt( exception { $bar->baz($hash_ref) }, undef, '... Bar::baz does not accept hash refs' ); + + my $array_ref = []; + is( exception { $bar->baz($array_ref) }, undef, '... Bar::baz can accept an array ref' ); + is($bar->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + isnt( exception { $bar->baz($scalar_ref) }, undef, '... Bar::baz does not accept a scalar ref' ); + + is( exception { $bar->bunch_of_stuff([1, 2, 3]) }, undef, '... Bar::bunch_of_stuff accepts an array of ints' ); + isnt( exception { $bar->bunch_of_stuff([qw[one two three]]) }, undef, '... Bar::bunch_of_stuff does not accept an array of strings' ); + + my $code_ref = sub { 1 }; + isnt( exception { $bar->baz($code_ref) }, undef, '... Bar::baz does not accept a code ref' ); +} + +# check some meta-stuff + +ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr'); +ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr'); +ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr'); +ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr'); +ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr'); +ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr'); +ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr'); +ok(!Bar->meta->has_attribute('blang'), '... Bar has a blang attr'); +ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr'); +ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr'); + +isnt(Foo->meta->get_attribute('foo'), + Bar->meta->get_attribute('foo'), + '... Foo and Bar have different copies of foo'); +isnt(Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('bar'), + '... Foo and Bar have different copies of bar'); +isnt(Foo->meta->get_attribute('baz'), + Bar->meta->get_attribute('baz'), + '... Foo and Bar have different copies of baz'); +isnt(Foo->meta->get_attribute('gorch'), + Bar->meta->get_attribute('gorch'), + '... Foo and Bar have different copies of gorch'); +isnt(Foo->meta->get_attribute('gloum'), + Bar->meta->get_attribute('gloum'), + '... Foo and Bar have different copies of gloum'); +isnt(Foo->meta->get_attribute('bling'), + Bar->meta->get_attribute('bling'), + '... Foo and Bar have different copies of bling'); +isnt(Foo->meta->get_attribute('bunch_of_stuff'), + Bar->meta->get_attribute('bunch_of_stuff'), + '... Foo and Bar have different copies of bunch_of_stuff'); + +ok(Bar->meta->get_attribute('bar')->has_type_constraint, + '... Bar::bar inherited the type constraint too'); +ok(Bar->meta->get_attribute('baz')->has_type_constraint, + '... Bar::baz inherited the type constraint too'); + +is(Bar->meta->get_attribute('bar')->type_constraint->name, + 'Str', '... Bar::bar inherited the right type constraint too'); + +is(Foo->meta->get_attribute('baz')->type_constraint->name, + 'Ref', '... Foo::baz inherited the right type constraint too'); +is(Bar->meta->get_attribute('baz')->type_constraint->name, + 'ArrayRef', '... Bar::baz inherited the right type constraint too'); + +ok(!Foo->meta->get_attribute('gorch')->is_required, + '... Foo::gorch is not a required attr'); +ok(Bar->meta->get_attribute('gorch')->is_required, + '... Bar::gorch is a required attr'); + +is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name, + 'ArrayRef', + '... Foo::bunch_of_stuff is an ArrayRef'); +is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name, + 'ArrayRef[Int]', + '... Bar::bunch_of_stuff is an ArrayRef[Int]'); + +ok(!Foo->meta->get_attribute('gloum')->is_lazy, + '... Foo::gloum is not a required attr'); +ok(Bar->meta->get_attribute('gloum')->is_lazy, + '... Bar::gloum is a required attr'); + +ok(!Foo->meta->get_attribute('foo')->should_coerce, + '... Foo::foo should not coerce'); +ok(Bar->meta->get_attribute('foo')->should_coerce, + '... Bar::foo should coerce'); + +ok(!Foo->meta->get_attribute('bling')->has_handles, + '... Foo::foo should not handles'); +ok(Bar->meta->get_attribute('bling')->has_handles, + '... Bar::foo should handles'); + +done_testing; diff --git a/t/attributes/attribute_lazy_initializer.t b/t/attributes/attribute_lazy_initializer.t new file mode 100644 index 0000000..7651ea4 --- /dev/null +++ b/t/attributes/attribute_lazy_initializer.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo' => ( + reader => 'get_lazy_foo', + lazy => 1, + default => 10, + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_w_type' => ( + reader => 'get_lazy_foo_w_type', + isa => 'Int', + lazy => 1, + default => 20, + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_w_type', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_builder' => ( + reader => 'get_lazy_foo_builder', + builder => 'get_foo_builder', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_builder', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_builder_w_type' => ( + reader => 'get_lazy_foo_builder_w_type', + isa => 'Int', + builder => 'get_foo_builder_w_type', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name'); + + $callback->($value * 2); + }, + ); + + sub get_foo_builder { 100 } + sub get_foo_builder_w_type { 1000 } +} + +{ + my $foo = Foo->new(foo => 10); + isa_ok($foo, 'Foo'); + + is($foo->get_foo, 20, 'initial value set to 2x given value'); + is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value'); + is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value'); + is($foo->get_lazy_foo_builder, 200, 'initial lazy value with builder set to 2x given value'); + is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value'); +} + +{ + package Bar; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +{ + my $bar = Bar->new(foo => 10); + isa_ok($bar, 'Bar'); + + is($bar->get_foo, 20, 'initial value set to 2x given value'); +} + +{ + package Fail::Bar; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + isa => 'Int', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->("Hello $value World"); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +isnt( exception { + Fail::Bar->new(foo => 10) +}, undef, '... this fails, because initializer returns a bad type' ); + +done_testing; diff --git a/t/attributes/attribute_names.t b/t/attributes/attribute_names.t new file mode 100644 index 0000000..af6ee1e --- /dev/null +++ b/t/attributes/attribute_names.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +my $exception_regex = qr/You must provide a name for the attribute/; +{ + package My::Role; + use Moose::Role; + + ::like( ::exception { + has; + }, $exception_regex, 'has; fails' ); + + ::like( ::exception { + has undef; + }, $exception_regex, 'has undef; fails' ); + + ::is( ::exception { + has "" => ( + is => 'bare', + ); + }, undef, 'has ""; works now' ); + + ::is( ::exception { + has 0 => ( + is => 'bare', + ); + }, undef, 'has 0; works now' ); +} + +{ + package My::Class; + use Moose; + + ::like( ::exception { + has; + }, $exception_regex, 'has; fails' ); + + ::like( ::exception { + has undef; + }, $exception_regex, 'has undef; fails' ); + + ::is( ::exception { + has "" => ( + is => 'bare', + ); + }, undef, 'has ""; works now' ); + + ::is( ::exception { + has 0 => ( + is => 'bare', + ); + }, undef, 'has 0; works now' ); +} + +done_testing; diff --git a/t/attributes/attribute_reader_generation.t b/t/attributes/attribute_reader_generation.t new file mode 100644 index 0000000..8c2e257 --- /dev/null +++ b/t/attributes/attribute_reader_generation.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + reader => 'get_foo' + ); + }; + ::ok(!$@, '... created the reader method okay'); + + eval { + has 'lazy_foo' => ( + reader => 'get_lazy_foo', + lazy => 1, + default => sub { 10 } + ); + }; + ::ok(!$@, '... created the lazy reader method okay') or warn $@; + + eval { + has 'lazy_weak_foo' => ( + reader => 'get_lazy_weak_foo', + lazy => 1, + default => sub { our $AREF = [] }, + weak_ref => 1, + ); + }; + ::ok(!$@, '... created the lazy weak reader method okay') or warn $@; + + my $warn; + + eval { + local $SIG{__WARN__} = sub { $warn = $_[0] }; + has 'mtfnpy' => ( + reder => 'get_mftnpy' + ); + }; + ::ok($warn, '... got a warning for mispelled attribute argument'); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + can_ok($foo, 'get_foo'); + is($foo->get_foo(), undef, '... got an undefined value'); + isnt( exception { + $foo->get_foo(100); + }, undef, '... get_foo is a read-only' ); + + ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot'); + + can_ok($foo, 'get_lazy_foo'); + is($foo->get_lazy_foo(), 10, '... got an deferred value'); + isnt( exception { + $foo->get_lazy_foo(100); + }, undef, '... get_lazy_foo is a read-only' ); + + is($foo->get_lazy_weak_foo(), $Foo::AREF, 'got the right value'); + ok($foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), + '... and it is weak'); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $attr = $foo->meta->find_attribute_by_name("lazy_foo"); + + isa_ok( $attr, "Moose::Meta::Attribute" ); + + ok( $attr->is_lazy, "it's lazy" ); + + is( $attr->get_raw_value($foo), undef, "raw value" ); + + is( $attr->get_value($foo), 10, "lazy value" ); + + is( $attr->get_raw_value($foo), 10, "raw value" ); + + my $lazy_weak_attr = $foo->meta->find_attribute_by_name("lazy_weak_foo"); + + is( $lazy_weak_attr->get_value($foo), $Foo::AREF, "it's the right value" ); + + ok( $foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), "and it is weak"); +} + +{ + my $foo = Foo->new(foo => 10, lazy_foo => 100); + isa_ok($foo, 'Foo'); + + is($foo->get_foo(), 10, '... got the correct value'); + is($foo->get_lazy_foo(), 100, '... got the correct value'); +} + +done_testing; diff --git a/t/attributes/attribute_required.t b/t/attributes/attribute_required.t new file mode 100644 index 0000000..f0b39b2 --- /dev/null +++ b/t/attributes/attribute_required.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'ro', required => 1); + has 'baz' => (is => 'rw', default => 100, required => 1); + has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1); +} + +{ + my $foo = Foo->new(bar => 10, baz => 20, boo => 100); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 20, '... got the right baz'); + is($foo->boo, 100, '... got the right boo'); +} + +{ + my $foo = Foo->new(bar => 10, boo => 5); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 100, '... got the right baz'); + is($foo->boo, 5, '... got the right boo'); +} + +{ + my $foo = Foo->new(bar => 10); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 100, '... got the right baz'); + is($foo->boo, 50, '... got the right boo'); +} + +#Yeah.. this doesn't work like this anymore, see below. (groditi) +#throws_ok { +# Foo->new(bar => 10, baz => undef); +#} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute'; + +#throws_ok { +# Foo->new(bar => 10, boo => undef); +#} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute'; + +is( exception { + Foo->new(bar => 10, baz => undef); +}, undef, '... undef is a valid attribute value' ); + +is( exception { + Foo->new(bar => 10, boo => undef); +}, undef, '... undef is a valid attribute value' ); + + +like( exception { + Foo->new; +}, qr/^Attribute \(bar\) is required/, '... must supply all the required attribute' ); + +done_testing; diff --git a/t/attributes/attribute_traits.t b/t/attributes/attribute_traits.t new file mode 100644 index 0000000..bcdf491 --- /dev/null +++ b/t/attributes/attribute_traits.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + traits => [qw/My::Attribute::Trait/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); + + has 'gorch' => ( + is => 'ro', + isa => 'Int', + default => sub { 10 } + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); +is($c->gorch, 10, '... got the right value for gorch'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +my $bar_attr = $c->meta->get_attribute('bar'); +does_ok($bar_attr, 'My::Attribute::Trait'); +ok($bar_attr->has_applied_traits, '... got the applied traits'); +is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits'); +is($bar_attr->foo, "blah", "attr initialized"); + +my $gorch_attr = $c->meta->get_attribute('gorch'); +ok(!$gorch_attr->does('My::Attribute::Trait'), '... gorch doesnt do the trait'); +ok(!$gorch_attr->has_applied_traits, '... no traits applied'); +is($gorch_attr->applied_traits, undef, '... no traits applied'); + +done_testing; diff --git a/t/attributes/attribute_traits_n_meta.t b/t/attributes/attribute_traits_n_meta.t new file mode 100644 index 0000000..dd43a45 --- /dev/null +++ b/t/attributes/attribute_traits_n_meta.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my ($self, $name, %options) = @_; + $options{is} = 'ro' + unless exists $options{is}; + $next->($self, $name, %options); + }; +} + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + metaclass => 'My::Meta::Attribute::DefaultReadOnly', + traits => [qw/My::Attribute::Trait/], + isa => 'Int', + alias_to => 'baz', + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +isa_ok($c->meta->get_attribute('bar'), 'My::Meta::Attribute::DefaultReadOnly'); +does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait'); +is($c->meta->get_attribute('bar')->_is_metadata, 'ro', '... got the right metaclass customization'); + +done_testing; diff --git a/t/attributes/attribute_traits_parameterized.t b/t/attributes/attribute_traits_parameterized.t new file mode 100644 index 0000000..cdf84b0 --- /dev/null +++ b/t/attributes/attribute_traits_parameterized.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +{ + package My::Attribute::Trait; + use Moose::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Moose; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'eman', + }, + }, + ], + is => 'bare', + ); +} + +{ + package My::Other::Class; + use Moose; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'reversed', + }, + -excludes => 'reversed_name', + }, + ], + is => 'bare', + ); +} + +my $attr = My::Class->meta->get_attribute('foo'); +is($attr->eman, 'oof', 'the aliased method is in the attribute'); +ok(!$attr->can('reversed'), "the method was not installed under the other class' alias"); + +my $other_attr = My::Other::Class->meta->get_attribute('foo'); +is($other_attr->reversed, 'oof', 'the aliased method is in the attribute'); +ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias"); +ok(!$other_attr->can('reversed_name'), "the method was not installed under the original name when that was excluded"); + +done_testing; diff --git a/t/attributes/attribute_traits_registered.t b/t/attributes/attribute_traits_registered.t new file mode 100644 index 0000000..3ce332a --- /dev/null +++ b/t/attributes/attribute_traits_registered.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; + + package Moose::Meta::Attribute::Custom::Trait::Aliased; + sub register_implementation { 'My::Attribute::Trait' } +} + +{ + package My::Other::Attribute::Trait; + use Moose::Role; + + my $method = sub { + 42; + }; + + has the_other_attr => ( isa => "Str", is => "rw", default => "oink" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + 'additional_method', + $method + ); + }; + + package Moose::Meta::Attribute::Custom::Trait::Other; + sub register_implementation { 'My::Other::Attribute::Trait' } +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + traits => [qw/Aliased/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); +} + +{ + package My::Derived::Class; + use Moose; + + extends 'My::Class'; + + has '+bar' => ( + traits => [qw/Other/], + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); + +can_ok($c, 'baz') and +is($c->baz, 100, '... got the right value for baz'); + +my $bar_attr = $c->meta->get_attribute('bar'); +does_ok($bar_attr, 'My::Attribute::Trait'); +is($bar_attr->foo, "blah", "attr initialized"); + +ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); +ok($bar_attr->does('Aliased'), "attr->does uses aliases"); +ok(!$bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); +ok(!$bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); + +my $quux = My::Derived::Class->new(bar => 1000); + +is($quux->bar, 1000, '... got the right value for bar'); + +can_ok($quux, 'baz'); +is($quux->baz, 1000, '... got the right value for baz'); + +my $derived_bar_attr = $quux->meta->get_attribute("bar"); +does_ok($derived_bar_attr, 'My::Attribute::Trait' ); + +is( $derived_bar_attr->foo, "blah", "attr initialized" ); + +does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' ); + +is($derived_bar_attr->the_other_attr, "oink", "attr initialized" ); + +ok(!$derived_bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); +ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases"); +ok(!$derived_bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); +ok(!$derived_bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); + +can_ok($quux, 'additional_method'); +is(eval { $quux->additional_method }, 42, '... got the right value for additional_method'); + +done_testing; diff --git a/t/attributes/attribute_triggers.t b/t/attributes/attribute_triggers.t new file mode 100644 index 0000000..5b86ac6 --- /dev/null +++ b/t/attributes/attribute_triggers.t @@ -0,0 +1,219 @@ +use strict; +use warnings; + +use Scalar::Util 'isweak'; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', + isa => 'Maybe[Bar]', + trigger => sub { + my ($self, $bar) = @_; + $bar->foo($self) if defined $bar; + }); + + has 'baz' => (writer => 'set_baz', + reader => 'get_baz', + isa => 'Baz', + trigger => sub { + my ($self, $baz) = @_; + $baz->foo($self); + }); + + + package Bar; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); + + package Baz; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + is( exception { + $foo->bar($bar); + }, undef, '... did not die setting bar' ); + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + is( exception { + $foo->bar(undef); + }, undef, '... did not die un-setting bar' ); + + is($foo->bar, undef, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + # test the writer + + is( exception { + $foo->set_baz($baz); + }, undef, '... did not die setting baz' ); + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +{ + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + my $foo = Foo->new(bar => $bar, baz => $baz); + isa_ok($foo, 'Foo'); + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +# some errors + +{ + package Bling; + use Moose; + + ::isnt( ::exception { + has('bling' => (is => 'rw', trigger => 'Fail')); + }, undef, '... a trigger must be a CODE ref' ); + + ::isnt( ::exception { + has('bling' => (is => 'rw', trigger => [])); + }, undef, '... a trigger must be a CODE ref' ); +} + +# Triggers do not fire on built values + +{ + package Blarg; + use Moose; + + our %trigger_calls; + our %trigger_vals; + has foo => (is => 'rw', default => sub { 'default foo value' }, + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{foo}++; + $trigger_vals{foo} = $val }); + has bar => (is => 'rw', lazy_build => 1, + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{bar}++; + $trigger_vals{bar} = $val }); + sub _build_bar { return 'default bar value' } + has baz => (is => 'rw', builder => '_build_baz', + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{baz}++; + $trigger_vals{baz} = $val }); + sub _build_baz { return 'default baz value' } +} + +{ + my $blarg; + is( exception { $blarg = Blarg->new; }, undef, 'Blarg->new() lives' ); + ok($blarg, 'Have a $blarg'); + foreach my $attr (qw/foo bar baz/) { + is($blarg->$attr(), "default $attr value", "$attr has default value"); + } + is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired'); + foreach my $attr (qw/foo bar baz/) { + $blarg->$attr("Different $attr value"); + } + is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign'); + is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); + + is( exception { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) }, undef, '->new() with parameters' ); + is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct'); + is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); +} + +# Triggers do not receive the meta-attribute as an argument, but do +# receive the old value + +{ + package Foo; + use Moose; + our @calls; + has foo => (is => 'rw', trigger => sub { push @calls, [@_] }); +} + +{ + my $attr = Foo->meta->get_attribute('foo'); + + my $foo = Foo->new; + $attr->set_value( $foo, 2 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on initial set via meta-API', + ); + @Foo::calls = (); + + $attr->set_value( $foo, 3 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on second set via meta-API', + ); + @Foo::calls = (); + + $attr->set_raw_value( $foo, 4 ); + + is_deeply( + \@Foo::calls, + [ ], + 'trigger not called using set_raw_value method', + ); + @Foo::calls = (); +} + +{ + my $foo = Foo->new(foo => 2); + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on construction', + ); + @Foo::calls = (); + + $foo->foo(3); + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on set (with old value)', + ); + @Foo::calls = (); + Foo->meta->make_immutable, redo if Foo->meta->is_mutable; +} + +done_testing; diff --git a/t/attributes/attribute_type_unions.t b/t/attributes/attribute_type_unions.t new file mode 100644 index 0000000..ab0ed60 --- /dev/null +++ b/t/attributes/attribute_type_unions.t @@ -0,0 +1,96 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef'); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is( exception { + $foo->bar([]) +}, undef, '... set bar successfully with an ARRAY ref' ); + +is( exception { + $foo->bar({}) +}, undef, '... set bar successfully with a HASH ref' ); + +isnt( exception { + $foo->bar(100) +}, undef, '... couldnt set bar successfully with a number' ); + +isnt( exception { + $foo->bar(sub {}) +}, undef, '... couldnt set bar successfully with a CODE ref' ); + +# check the constructor + +is( exception { + Foo->new(bar => []) +}, undef, '... created new Foo with bar successfully set with an ARRAY ref' ); + +is( exception { + Foo->new(bar => {}) +}, undef, '... created new Foo with bar successfully set with a HASH ref' ); + +isnt( exception { + Foo->new(bar => 50) +}, undef, '... didnt create a new Foo with bar as a number' ); + +isnt( exception { + Foo->new(bar => sub {}) +}, undef, '... didnt create a new Foo with bar as a CODE ref' ); + +{ + package Bar; + use Moose; + + has 'baz' => (is => 'rw', isa => 'Str | CodeRef'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +is( exception { + $bar->baz('a string') +}, undef, '... set baz successfully with a string' ); + +is( exception { + $bar->baz(sub { 'a sub' }) +}, undef, '... set baz successfully with a CODE ref' ); + +isnt( exception { + $bar->baz(\(my $var1)) +}, undef, '... couldnt set baz successfully with a SCALAR ref' ); + +isnt( exception { + $bar->baz({}) +}, undef, '... couldnt set bar successfully with a HASH ref' ); + +# check the constructor + +is( exception { + Bar->new(baz => 'a string') +}, undef, '... created new Bar with baz successfully set with a string' ); + +is( exception { + Bar->new(baz => sub { 'a sub' }) +}, undef, '... created new Bar with baz successfully set with a CODE ref' ); + +isnt( exception { + Bar->new(baz => \(my $var2)) +}, undef, '... didnt create a new Bar with baz as a number' ); + +isnt( exception { + Bar->new(baz => {}) +}, undef, '... didnt create a new Bar with baz as a HASH ref' ); + +done_testing; diff --git a/t/attributes/attribute_without_any_methods.t b/t/attributes/attribute_without_any_methods.t new file mode 100644 index 0000000..f1310fb --- /dev/null +++ b/t/attributes/attribute_without_any_methods.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Class; + +my $meta = Moose::Meta::Class->create('Banana'); + +my $warn; +$SIG{__WARN__} = sub { $warn = "@_" }; + +$meta->add_attribute('foo'); +like $warn, qr/Attribute \(foo\) of class Banana has no associated methods/, + 'correct error message'; + +$warn = ''; +$meta->add_attribute('bar', is => 'bare'); +is $warn, '', 'add attribute with no methods and is => "bare"'; + +done_testing; diff --git a/t/attributes/attribute_writer_generation.t b/t/attributes/attribute_writer_generation.t new file mode 100644 index 0000000..ceb5acb --- /dev/null +++ b/t/attributes/attribute_writer_generation.t @@ -0,0 +1,117 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util 'isweak'; + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + ); + }; + ::ok(!$@, '... created the writer method okay'); + + eval { + has 'foo_required' => ( + reader => 'get_foo_required', + writer => 'set_foo_required', + required => 1, + ); + }; + ::ok(!$@, '... created the required writer method okay'); + + eval { + has 'foo_int' => ( + reader => 'get_foo_int', + writer => 'set_foo_int', + isa => 'Int', + ); + }; + ::ok(!$@, '... created the writer method with type constraint okay'); + + eval { + has 'foo_weak' => ( + reader => 'get_foo_weak', + writer => 'set_foo_weak', + weak_ref => 1 + ); + }; + ::ok(!$@, '... created the writer method with weak_ref okay'); +} + +{ + my $foo = Foo->new(foo_required => 'required'); + isa_ok($foo, 'Foo'); + + # regular writer + + can_ok($foo, 'set_foo'); + is($foo->get_foo(), undef, '... got an unset value'); + is( exception { + $foo->set_foo(100); + }, undef, '... set_foo wrote successfully' ); + is($foo->get_foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + isnt( exception { + Foo->new; + }, undef, '... cannot create without the required attribute' ); + + can_ok($foo, 'set_foo_required'); + is($foo->get_foo_required(), 'required', '... got an unset value'); + is( exception { + $foo->set_foo_required(100); + }, undef, '... set_foo_required wrote successfully' ); + is($foo->get_foo_required(), 100, '... got the correct set value'); + + isnt( exception { + $foo->set_foo_required(); + }, undef, '... set_foo_required died successfully with no value' ); + + is( exception { + $foo->set_foo_required(undef); + }, undef, '... set_foo_required did accept undef' ); + + ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); + + # with type constraint + + can_ok($foo, 'set_foo_int'); + is($foo->get_foo_int(), undef, '... got an unset value'); + is( exception { + $foo->set_foo_int(100); + }, undef, '... set_foo_int wrote successfully' ); + is($foo->get_foo_int(), 100, '... got the correct set value'); + + isnt( exception { + $foo->set_foo_int("Foo"); + }, undef, '... set_foo_int died successfully' ); + + ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); + + # with weak_ref + + my $test = []; + + can_ok($foo, 'set_foo_weak'); + is($foo->get_foo_weak(), undef, '... got an unset value'); + is( exception { + $foo->set_foo_weak($test); + }, undef, '... set_foo_weak wrote successfully' ); + is($foo->get_foo_weak(), $test, '... got the correct set value'); + + ok(isweak($foo->{foo_weak}), '... it is a weak reference'); +} + +done_testing; diff --git a/t/attributes/bad_coerce.t b/t/attributes/bad_coerce.t new file mode 100644 index 0000000..daffe91 --- /dev/null +++ b/t/attributes/bad_coerce.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + + use Moose; + + ::like(::exception { + has foo => ( + is => 'ro', + isa => 'Str', + coerce => 1, + ); + }, + qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/, + 'Cannot coerce unless the type has a coercion'); + + ::like(::exception { + has bar => ( + is => 'ro', + isa => 'Str', + coerce => 1, + ); + }, + qr/\QYou cannot coerce an attribute (bar) unless its type (Str) has a coercion/, + 'Cannot coerce unless the type has a coercion - different attribute'); +} + +done_testing; diff --git a/t/attributes/chained_coercion.t b/t/attributes/chained_coercion.t new file mode 100644 index 0000000..853f251 --- /dev/null +++ b/t/attributes/chained_coercion.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Baz' => from 'HashRef' => via { Baz->new($_) }; + + has 'hello' => ( + is => 'ro', + isa => 'Str', + ); + + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Bar' => from 'HashRef' => via { Bar->new($_) }; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + coerce => 1 + ); + + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + coerce => 1, + ); +} + +my $foo = Foo->new(bar => { baz => { hello => 'World' } }); +isa_ok($foo, 'Foo'); +isa_ok($foo->bar, 'Bar'); +isa_ok($foo->bar->baz, 'Baz'); +is($foo->bar->baz->hello, 'World', '... this all worked fine'); + +done_testing; diff --git a/t/attributes/clone_weak.t b/t/attributes/clone_weak.t new file mode 100644 index 0000000..1f5162d --- /dev/null +++ b/t/attributes/clone_weak.t @@ -0,0 +1,177 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( + is => 'ro', + weak_ref => 1, + ); +} + +{ + package MyScopeGuard; + + sub new { + my ($class, $cb) = @_; + bless { cb => $cb }, $class; + } + + sub DESTROY { shift->{cb}->() } +} + +{ + my $destroyed = 0; + + my $foo = do { + my $bar = MyScopeGuard->new(sub { $destroyed++ }); + my $foo = Foo->new({ bar => $bar }); + my $clone = $foo->meta->clone_object($foo); + + is $destroyed, 0; + + $clone; + }; + + isa_ok($foo, 'Foo'); + is $foo->bar, undef; + is $destroyed, 1; +} + +{ + my $clone; + { + my $anon = Moose::Meta::Class->create_anon_class; + + my $foo = $anon->new_object; + isa_ok($foo, $anon->name); + ok(Class::MOP::class_of($foo), "has a metaclass"); + + $clone = $anon->clone_object($foo); + isa_ok($clone, $anon->name); + ok(Class::MOP::class_of($clone), "has a metaclass"); + } + + ok(Class::MOP::class_of($clone), "still has a metaclass"); +} + +{ + package Foo::Meta::Attr::Trait; + use Moose::Role; + + has value_slot => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { shift->name }, + ); + + has count_slot => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { '<<COUNT>>' . shift->name }, + ); + + sub slots { + my $self = shift; + return ($self->value_slot, $self->count_slot); + } + + sub _set_count { + my $self = shift; + my ($instance) = @_; + my $mi = $self->associated_class->get_meta_instance; + $mi->set_slot_value( + $instance, + $self->count_slot, + ($mi->get_slot_value($instance, $self->count_slot) || 0) + 1, + ); + } + + sub _clear_count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->deinitialize_slot( + $instance, $self->count_slot + ); + } + + sub has_count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->has_slot_value( + $instance, $self->count_slot + ); + } + + sub count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->get_slot_value( + $instance, $self->count_slot + ); + } + + after set_initial_value => sub { + shift->_set_count(@_); + }; + + after set_value => sub { + shift->_set_count(@_); + }; + + around _inline_instance_set => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + + return 'do { ' + . $mi->inline_set_slot_value( + $instance, + $self->count_slot, + $mi->inline_get_slot_value( + $instance, $self->count_slot + ) . ' + 1' + ) . ';' + . $self->$orig(@_) + . '}'; + }; + + after clear_value => sub { + shift->_clear_count(@_); + }; +} + +{ + package Bar; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['Foo::Meta::Attr::Trait'], + }, + ); + + has baz => ( is => 'rw' ); +} + +{ + my $attr = Bar->meta->find_attribute_by_name('baz'); + + my $bar = Bar->new(baz => 1); + is($attr->count($bar), 1, "right count"); + + $bar->baz(2); + is($attr->count($bar), 2, "right count"); + + my $clone = $bar->meta->clone_object($bar); + is($attr->count($clone), $attr->count($bar), "right count"); +} + +done_testing; diff --git a/t/attributes/default_class_role_types.t b/t/attributes/default_class_role_types.t new file mode 100644 index 0000000..c0590ce --- /dev/null +++ b/t/attributes/default_class_role_types.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Foo; + use Moose; + + has unknown_class => ( + is => 'ro', + isa => 'UnknownClass', + ); + + has unknown_role => ( + is => 'ro', + does => 'UnknownRole', + ); +} + +{ + my $meta = Foo->meta; + + my $class_tc = $meta->get_attribute('unknown_class')->type_constraint; + isa_ok($class_tc, 'Moose::Meta::TypeConstraint::Class'); + is($class_tc, find_type_constraint('UnknownClass'), + "class type is registered"); + like( + exception { subtype 'UnknownClass', as 'Str'; }, + qr/The type constraint 'UnknownClass' has already been created in Foo and cannot be created again in main/, + "Can't redefine implicitly defined class types" + ); + + my $role_tc = $meta->get_attribute('unknown_role')->type_constraint; + isa_ok($role_tc, 'Moose::Meta::TypeConstraint::Role'); + is($role_tc, find_type_constraint('UnknownRole'), + "role type is registered"); + like( + exception { subtype 'UnknownRole', as 'Str'; }, + qr/The type constraint 'UnknownRole' has already been created in Foo and cannot be created again in main/, + "Can't redefine implicitly defined class types" + ); +} + +done_testing; diff --git a/t/attributes/default_undef.t b/t/attributes/default_undef.t new file mode 100644 index 0000000..5c4bb55 --- /dev/null +++ b/t/attributes/default_undef.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Maybe[Int]', + default => undef, + predicate => 'has_foo', + ); +} + +with_immutable { + is(Foo->new->foo, undef); + ok(Foo->new->has_foo); +} 'Foo'; + +done_testing; diff --git a/t/attributes/delegation_and_modifiers.t b/t/attributes/delegation_and_modifiers.t new file mode 100644 index 0000000..a0b9114 --- /dev/null +++ b/t/attributes/delegation_and_modifiers.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Bar; + use Moose; + + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + lazy => 1, + default => sub { Bar->new }, + handles => [qw[ baz gorch ]] + ); + + package Foo::Extended; + use Moose; + + extends 'Foo'; + + has 'test' => ( + is => 'rw', + isa => 'Bool', + default => sub { 0 }, + ); + + around 'bar' => sub { + my $next = shift; + my $self = shift; + + $self->test(1); + $self->$next(); + }; +} + +my $foo = Foo::Extended->new; +isa_ok($foo, 'Foo::Extended'); +isa_ok($foo, 'Foo'); + +ok(!$foo->test, '... the test value has not been changed'); + +is($foo->baz, 'Bar::baz', '... got the right delegated method'); + +ok($foo->test, '... the test value has now been changed'); + +done_testing; diff --git a/t/attributes/delegation_arg_aliasing.t b/t/attributes/delegation_arg_aliasing.t new file mode 100644 index 0000000..58a6b0a --- /dev/null +++ b/t/attributes/delegation_arg_aliasing.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + sub aliased { + my $self = shift; + $_[1] = $_[0]; + } +} + +{ + package HasFoo; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Foo', + handles => { + foo_aliased => 'aliased', + foo_aliased_curried => ['aliased', 'bar'], + } + ); +} + +my $hasfoo = HasFoo->new(foo => Foo->new); +my $x; +$hasfoo->foo->aliased('foo', $x); +is($x, 'foo', "direct aliasing works"); +undef $x; +$hasfoo->foo_aliased('foo', $x); +is($x, 'foo', "delegated aliasing works"); +undef $x; +$hasfoo->foo_aliased_curried($x); +is($x, 'bar', "delegated aliasing with currying works"); + +done_testing; diff --git a/t/attributes/delegation_target_not_loaded.t b/t/attributes/delegation_target_not_loaded.t new file mode 100644 index 0000000..3938786 --- /dev/null +++ b/t/attributes/delegation_target_not_loaded.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package X; + + use Moose; + + ::like( + ::exception{ has foo => ( + is => 'ro', + isa => 'Foo', + handles => qr/.*/, + ) + }, + qr/\QThe foo attribute is trying to delegate to a class which has not been loaded - Foo/, + 'cannot delegate to a class which is not yet loaded' + ); + + ::like( + ::exception{ has foo => ( + is => 'ro', + does => 'Role::Foo', + handles => qr/.*/, + ) + }, + qr/\QThe foo attribute is trying to delegate to a role which has not been loaded - Role::Foo/, + 'cannot delegate to a role which is not yet loaded' + ); +} + +done_testing; diff --git a/t/attributes/illegal_options_for_inheritance.t b/t/attributes/illegal_options_for_inheritance.t new file mode 100644 index 0000000..59ce26e --- /dev/null +++ b/t/attributes/illegal_options_for_inheritance.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + ); + + has bar => ( + clearer => 'clear_bar', + ); +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; + + ::is( ::exception { has '+foo' => (is => 'rw') }, undef, "can override is" ); + ::like( ::exception { has '+foo' => (reader => 'bar') }, qr/illegal/, "can't override reader" ); + ::is( ::exception { has '+foo' => (clearer => 'baz') }, undef, "can override unspecified things" ); + + ::like( ::exception { has '+bar' => (clearer => 'quux') }, qr/illegal/, "can't override clearer" ); + ::is( ::exception { has '+bar' => (predicate => 'has_bar') }, undef, "can override unspecified things" ); +} + +{ + package Bar::Meta::Attribute; + use Moose::Role; + + has my_illegal_option => (is => 'ro'); + + around illegal_options_for_inheritance => sub { + return (shift->(@_), 'my_illegal_option'); + }; +} + +{ + package Bar; + use Moose; + + ::is( ::exception { + has bar => ( + traits => ['Bar::Meta::Attribute'], + my_illegal_option => 'FOO', + is => 'bare', + ); + }, undef, "can use illegal options" ); + + has baz => ( + traits => ['Bar::Meta::Attribute'], + is => 'bare', + ); +} + +{ + package Bar::Sub; + use Moose; + + extends 'Bar'; + + ::like( ::exception { has '+bar' => (my_illegal_option => 'BAR') }, qr/illegal/, "can't override illegal attribute" ); + ::is( ::exception { has '+baz' => (my_illegal_option => 'BAR') }, undef, "can add illegal option if superclass doesn't set it" ); +} + +my $bar_attr = Bar->meta->get_attribute('bar'); +ok((grep { $_ eq 'my_illegal_option' } $bar_attr->illegal_options_for_inheritance) > 0, '... added my_illegal_option as illegal option for inheritance'); + +done_testing; diff --git a/t/attributes/inherit_lazy_build.t b/t/attributes/inherit_lazy_build.t new file mode 100644 index 0000000..35919e5 --- /dev/null +++ b/t/attributes/inherit_lazy_build.t @@ -0,0 +1,75 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Parent; + use Moose; + has attr => ( is => 'rw', isa => 'Str' ); +} + +{ + package Child; + use Moose; + extends 'Parent'; + + has '+attr' => ( lazy_build => 1 ); + + sub _build_attr { + return 'value'; + } +} + +my $parent = Parent->new(); +my $child = Child->new(); + +ok( + !$parent->meta->get_attribute('attr')->is_lazy_build, + 'attribute in parent does not have lazy_build trait' +); +ok( + !$parent->meta->get_attribute('attr')->is_lazy, + 'attribute in parent does not have lazy trait' +); +ok( + !$parent->meta->get_attribute('attr')->has_builder, + 'attribute in parent does not have a builder method' +); +ok( + !$parent->meta->get_attribute('attr')->has_clearer, + 'attribute in parent does not have a clearer method' +); +ok( + !$parent->meta->get_attribute('attr')->has_predicate, + 'attribute in parent does not have a predicate method' +); + +ok( + $child->meta->get_attribute('attr')->is_lazy_build, + 'attribute in child has the lazy_build trait' +); +ok( + $child->meta->get_attribute('attr')->is_lazy, + 'attribute in child has the lazy trait' +); +ok( + $child->meta->get_attribute('attr')->has_builder, + 'attribute in child has a builder method' +); +ok( + $child->meta->get_attribute('attr')->has_clearer, + 'attribute in child has a clearer method' +); +ok( + $child->meta->get_attribute('attr')->has_predicate, + 'attribute in child has a predicate method' +); + +is( + $child->attr, 'value', + 'attribute defined as lazy_build in child is properly built' +); + +done_testing; diff --git a/t/attributes/lazy_no_default.t b/t/attributes/lazy_no_default.t new file mode 100644 index 0000000..c2ff635 --- /dev/null +++ b/t/attributes/lazy_no_default.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + ::like( + ::exception{ has foo => ( + is => 'ro', + lazy => 1, + ); + }, + qr/\QYou cannot have a lazy attribute (foo) without specifying a default value for it/, + 'lazy without a default or builder throws an error' + ); +} + +done_testing; diff --git a/t/attributes/method_generation_rules.t b/t/attributes/method_generation_rules.t new file mode 100644 index 0000000..15cabc0 --- /dev/null +++ b/t/attributes/method_generation_rules.t @@ -0,0 +1,61 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + + is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before + is => rw, accessor => _foo # turns into (accessor => _foo) + is => ro, accessor => _foo # error, accesor is rw + +=cut + +sub make_class { + my ($is, $attr, $class) = @_; + + eval "package $class; use Moose; has 'foo' => ( is => '$is', $attr => '_foo' );"; + + return $@ ? die $@ : $class; +} + +my $obj; +my $class; + +$class = make_class('rw', 'writer', 'Test::Class::WriterRW'); +ok($class, "Can define attr with rw + writer"); + +$obj = $class->new(); + +can_ok($obj, qw/foo _foo/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->foo(), 1, "$class->foo is reader"); +isnt( exception {$obj->foo(2)}, undef, "$class->foo is not writer" ); # this should fail +ok(!defined $obj->_foo(), "$class->_foo is not reader"); + +$class = make_class('ro', 'writer', 'Test::Class::WriterRO'); +ok($class, "Can define attr with ro + writer"); + +$obj = $class->new(); + +can_ok($obj, qw/foo _foo/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->foo(), 1, "$class->foo is reader"); +isnt( exception {$obj->foo(1)}, undef, "$class->foo is not writer" ); +isnt($obj->_foo(), 1, "$class->_foo is not reader"); + +$class = make_class('rw', 'accessor', 'Test::Class::AccessorRW'); +ok($class, "Can define attr with rw + accessor"); + +$obj = $class->new(); + +can_ok($obj, qw/_foo/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->_foo(), 1, "$class->foo is reader"); + +isnt( exception { make_class('ro', 'accessor', "Test::Class::AccessorRO"); }, undef, "Cant define attr with ro + accessor" ); + +done_testing; diff --git a/t/attributes/misc_attribute_coerce_lazy.t b/t/attributes/misc_attribute_coerce_lazy.t new file mode 100644 index 0000000..341e55d --- /dev/null +++ b/t/attributes/misc_attribute_coerce_lazy.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + + +{ + package HTTPHeader; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +{ + package Request; + use Moose; + use Moose::Util::TypeConstraints; + + subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + + coerce Header + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'headers' => ( + is => 'rw', + isa => 'Header', + coerce => 1, + lazy => 1, + default => sub { [ 'content-type', 'text/html' ] } + ); +} + +my $r = Request->new; +isa_ok($r, 'Request'); + +is( exception { + $r->headers; +}, undef, '... this coerces and passes the type constraint even with lazy' ); + +done_testing; diff --git a/t/attributes/misc_attribute_tests.t b/t/attributes/misc_attribute_tests.t new file mode 100644 index 0000000..7d392aa --- /dev/null +++ b/t/attributes/misc_attribute_tests.t @@ -0,0 +1,270 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + { + package Test::Attribute::Inline::Documentation; + use Moose; + + has 'foo' => ( + documentation => q{ + The 'foo' attribute is my favorite + attribute in the whole wide world. + }, + is => 'bare', + ); + } + + my $foo_attr = Test::Attribute::Inline::Documentation->meta->get_attribute('foo'); + + ok($foo_attr->has_documentation, '... the foo has docs'); + is($foo_attr->documentation, + q{ + The 'foo' attribute is my favorite + attribute in the whole wide world. + }, + '... got the foo docs'); +} + +{ + { + package Test::For::Lazy::TypeConstraint; + use Moose; + use Moose::Util::TypeConstraints; + + has 'bad_lazy_attr' => ( + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => sub { "test" }, + ); + + has 'good_lazy_attr' => ( + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => sub { [] }, + ); + + } + + my $test = Test::For::Lazy::TypeConstraint->new; + isa_ok($test, 'Test::For::Lazy::TypeConstraint'); + + isnt( exception { + $test->bad_lazy_attr; + }, undef, '... this does not work' ); + + is( exception { + $test->good_lazy_attr; + }, undef, '... this does not work' ); +} + +{ + { + package Test::Arrayref::Attributes; + use Moose; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + + my $test = Test::Arrayref::Attributes->new; + isa_ok($test, 'Test::Arrayref::Attributes'); + can_ok($test, qw(foo bar baz)); + +} + +{ + { + package Test::Arrayref::RoleAttributes::Role; + use Moose::Role; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + { + package Test::Arrayref::RoleAttributes; + use Moose; + with 'Test::Arrayref::RoleAttributes::Role'; + } + + my $test = Test::Arrayref::RoleAttributes->new; + isa_ok($test, 'Test::Arrayref::RoleAttributes'); + can_ok($test, qw(foo bar baz)); + +} + +{ + { + package Test::UndefDefault::Attributes; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + default => sub { return } + ); + + } + + isnt( exception { + Test::UndefDefault::Attributes->new; + }, undef, '... default must return a value which passes the type constraint' ); + +} + +{ + { + package OverloadedStr; + use Moose; + use overload '""' => sub { 'this is *not* a string' }; + + has 'a_str' => ( isa => 'Str' , is => 'rw' ); + } + + my $moose_obj = OverloadedStr->new; + + is($moose_obj->a_str( 'foobar' ), 'foobar', 'setter took string'); + ok($moose_obj, 'this is a *not* a string'); + + like( exception { + $moose_obj->a_str( $moose_obj ) + }, qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' with value .*OverloadedStr/, '... dies without overloading the string' ); + +} + +{ + { + package OverloadBreaker; + use Moose; + + has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 ); + } + + like( exception { + OverloadBreaker->new; + }, qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' with value 7\.5/, '... this doesnt trip overload to break anymore ' ); + + is( exception { + OverloadBreaker->new(a_num => 5); + }, undef, '... this works fine though' ); + +} + +{ + { + package Test::Builder::Attribute; + use Moose; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + sub build_foo { return "works" }; + } + + my $meta = Test::Builder::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + + ok($foo_attr->is_required, "foo is required"); + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "build_foo", ".. and it's named build_foo"); + + my $instance = Test::Builder::Attribute->new; + is($instance->foo, 'works', "foo builder works"); +} + +{ + { + package Test::Builder::Attribute::Broken; + use Moose; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + } + + isnt( exception { + Test::Builder::Attribute::Broken->new; + }, undef, '... no builder, wtf' ); +} + + +{ + { + package Test::LazyBuild::Attribute; + use Moose; + + has 'foo' => ( lazy_build => 1, is => 'ro'); + has '_foo' => ( lazy_build => 1, is => 'ro'); + has 'fool' => ( lazy_build => 1, is => 'ro'); + sub _build_foo { return "works" }; + sub _build__foo { return "works too" }; + } + + my $meta = Test::LazyBuild::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + my $_foo_attr = $meta->get_attribute("_foo"); + + ok($foo_attr->is_lazy, "foo is lazy"); + ok($foo_attr->is_lazy_build, "foo is lazy_build"); + + ok($foo_attr->has_clearer, "foo has clearer"); + is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo"); + + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "_build_foo", ".. and it's named build_foo"); + + ok($foo_attr->has_predicate, "foo has predicate"); + is($foo_attr->predicate, "has_foo", ".. and it's named has_foo"); + + ok($_foo_attr->is_lazy, "_foo is lazy"); + ok(!$_foo_attr->is_required, "lazy_build attributes are no longer automatically required"); + ok($_foo_attr->is_lazy_build, "_foo is lazy_build"); + + ok($_foo_attr->has_clearer, "_foo has clearer"); + is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo"); + + ok($_foo_attr->has_builder, "_foo has builder"); + is($_foo_attr->builder, "_build__foo", ".. and it's named _build_foo"); + + ok($_foo_attr->has_predicate, "_foo has predicate"); + is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo"); + + my $instance = Test::LazyBuild::Attribute->new; + ok(!$instance->has_foo, "noo foo value yet"); + ok(!$instance->_has_foo, "noo _foo value yet"); + is($instance->foo, 'works', "foo builder works"); + is($instance->_foo, 'works too', "foo builder works too"); + like( exception { $instance->fool }, qr/Test::LazyBuild::Attribute does not support builder method \'_build_fool\' for attribute \'fool\'/, "Correct error when a builder method is not present" ); + +} + +{ + package OutOfClassTest; + + use Moose; +} + +is( exception { OutOfClassTest::has('foo', is => 'bare'); }, undef, 'create attr via direct sub call' ); +is( exception { OutOfClassTest->can('has')->('bar', is => 'bare'); }, undef, 'create attr via can' ); + +ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call'); +ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can'); + + +{ + { + package Foo; + use Moose; + + ::like( ::exception { has 'foo' => ( 'ro', isa => 'Str' ) }, qr/\QYou must pass an even number of attribute options/, 'has throws error with odd number of attribute options' ); + } + +} + +done_testing; diff --git a/t/attributes/more_attr_delegation.t b/t/attributes/more_attr_delegation.t new file mode 100644 index 0000000..d40bb03 --- /dev/null +++ b/t/attributes/more_attr_delegation.t @@ -0,0 +1,263 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +This tests the more complex +delegation cases and that they +do not fail at compile time. + +=cut + +{ + + package ChildASuper; + use Moose; + + sub child_a_super_method { "as" } + + package ChildA; + use Moose; + + extends "ChildASuper"; + + sub child_a_method_1 { "a1" } + sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } + + package ChildASub; + use Moose; + + extends "ChildA"; + + sub child_a_method_3 { "a3" } + + package ChildB; + use Moose; + + sub child_b_method_1 { "b1" } + sub child_b_method_2 { "b2" } + sub child_b_method_3 { "b3" } + + package ChildC; + use Moose; + + sub child_c_method_1 { "c1" } + sub child_c_method_2 { "c2" } + sub child_c_method_3_la { "c3" } + sub child_c_method_4_la { "c4" } + + package ChildD; + use Moose; + + sub child_d_method_1 { "d1" } + sub child_d_method_2 { "d2" } + + package ChildE; + # no Moose + + sub new { bless {}, shift } + sub child_e_method_1 { "e1" } + sub child_e_method_2 { "e2" } + + package ChildF; + # no Moose + + sub new { bless {}, shift } + sub child_f_method_1 { "f1" } + sub child_f_method_2 { "f2" } + + $INC{'ChildF.pm'} = __FILE__; + + package ChildG; + use Moose; + + sub child_g_method_1 { "g1" } + + package ChildH; + use Moose; + + sub child_h_method_1 { "h1" } + sub parent_method_1 { "child_parent_1" } + + package ChildI; + use Moose; + + sub child_i_method_1 { "i1" } + sub parent_method_1 { "child_parent_1" } + + package Parent; + use Moose; + + sub parent_method_1 { "parent_1" } + ::can_ok('Parent', 'parent_method_1'); + + ::isnt( ::exception { + has child_a => ( + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + }, undef, "all_methods requires explicit isa" ); + + ::is( ::exception { + has child_a => ( + isa => "ChildA", + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + }, undef, "allow all_methods with explicit isa" ); + + ::is( ::exception { + has child_b => ( + is => 'ro', + default => sub { ChildB->new }, + handles => [qw/child_b_method_1/], + ); + }, undef, "don't need to declare isa if method list is predefined" ); + + ::is( ::exception { + has child_c => ( + isa => "ChildC", + is => "ro", + default => sub { ChildC->new }, + handles => qr/_la$/, + ); + }, undef, "can declare regex collector" ); + + ::isnt( ::exception { + has child_d => ( + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + } + ); + }, undef, "can't create attr with generative handles parameter and no isa" ); + + ::is( ::exception { + has child_d => ( + isa => "ChildD", + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + return; + } + ); + }, undef, "can't create attr with generative handles parameter and no isa" ); + + ::is( ::exception { + has child_e => ( + isa => "ChildE", + is => "ro", + default => sub { ChildE->new }, + handles => ["child_e_method_2"], + ); + }, undef, "can delegate to non moose class using explicit method list" ); + + my $delegate_class; + ::is( ::exception { + has child_f => ( + isa => "ChildF", + is => "ro", + default => sub { ChildF->new }, + handles => sub { + $delegate_class = $_[1]->name; + return; + }, + ); + }, undef, "subrefs on non moose class give no meta" ); + + ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); + + ::is( ::exception { + has child_g => ( + isa => "ChildG", + default => sub { ChildG->new }, + handles => ["child_g_method_1"], + ); + }, undef, "can delegate to object even without explicit reader" ); + + ::can_ok('Parent', 'parent_method_1'); + ::isnt( ::exception { + has child_h => ( + isa => "ChildH", + is => "ro", + default => sub { ChildH->new }, + handles => sub { map { $_, $_ } $_[1]->get_all_method_names }, + ); + }, undef, "Can't override exisiting class method in delegate" ); + ::can_ok('Parent', 'parent_method_1'); + + ::is( ::exception { + has child_i => ( + isa => "ChildI", + is => "ro", + default => sub { ChildI->new }, + handles => sub { + map { $_, $_ } grep { !/^parent_method_1|meta$/ } + $_[1]->get_all_method_names; + }, + ); + }, undef, "Test handles code ref for skipping predefined methods" ); + + + sub parent_method { "p" } +} + +# sanity + +isa_ok( my $p = Parent->new, "Parent" ); +isa_ok( $p->child_a, "ChildA" ); +isa_ok( $p->child_b, "ChildB" ); +isa_ok( $p->child_c, "ChildC" ); +isa_ok( $p->child_d, "ChildD" ); +isa_ok( $p->child_e, "ChildE" ); +isa_ok( $p->child_f, "ChildF" ); +isa_ok( $p->child_i, "ChildI" ); + +ok(!$p->can('child_g'), '... no child_g accessor defined'); +ok(!$p->can('child_h'), '... no child_h accessor defined'); + + +is( $p->parent_method, "p", "parent method" ); +is( $p->child_a->child_a_super_method, "as", "child supermethod" ); +is( $p->child_a->child_a_method_1, "a1", "child method" ); + +can_ok( $p, "child_a_super_method" ); +can_ok( $p, "child_a_method_1" ); +can_ok( $p, "child_a_method_2" ); +ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" ); + +is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" ); +is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" ); + + +can_ok( $p, "child_b_method_1" ); +ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" ); + + +ok( !$p->can($_), "none of ChildD's methods ($_)" ) + for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods(); + +can_ok( $p, "child_c_method_3_la" ); +can_ok( $p, "child_c_method_4_la" ); + +is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" ); + +can_ok( $p, "child_e_method_2" ); +ok( !$p->can("child_e_method_1"), "but not child_e_method_1"); + +is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" ); + +can_ok( $p, "child_g_method_1" ); +is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" ); + +can_ok( $p, "child_i_method_1" ); +is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" ); + +done_testing; diff --git a/t/attributes/no_init_arg.t b/t/attributes/no_init_arg.t new file mode 100644 index 0000000..181e0c2 --- /dev/null +++ b/t/attributes/no_init_arg.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; + + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + is => "rw", + init_arg => undef, + ); + }; + ::ok(!$@, '... created the attr okay'); +} + +{ + my $foo = Foo->new( foo => "bar" ); + isa_ok($foo, 'Foo'); + + is( $foo->foo, undef, "field is not set via init arg" ); + + $foo->foo("blah"); + + is( $foo->foo, "blah", "field is set via setter" ); +} + +done_testing; diff --git a/t/attributes/no_slot_access.t b/t/attributes/no_slot_access.t new file mode 100644 index 0000000..22405ba --- /dev/null +++ b/t/attributes/no_slot_access.t @@ -0,0 +1,87 @@ +use strict; +use warnings; + +{ + package SomeAwesomeDB; + + sub new_row { } + sub read { } + sub write { } +} + +{ + package MooseX::SomeAwesomeDBFields; + + # implementation of methods not called in the example deliberately + # omitted + + use Moose::Role; + + sub inline_create_instance { + my ( $self, $classvar ) = @_; + + "bless SomeAwesomeDB::new_row(), $classvar"; + } + + sub inline_get_slot_value { + my ( $self, $invar, $slot ) = @_; + + "SomeAwesomeDB::read($invar, \"$slot\")"; + } + + sub inline_set_slot_value { + my ( $self, $invar, $slot, $valexp ) = @_; + + "SomeAwesomeDB::write($invar, \"$slot\", $valexp)"; + } + + sub inline_is_slot_initialized { + my ( $self, $invar, $slot ) = @_; + + "1"; + } + + sub inline_initialize_slot { + my ( $self, $invar, $slot ) = @_; + + ""; + } + + sub inline_slot_access { + die "inline_slot_access should not have been used"; + } +} + +{ + package Toy; + + use Moose; + use Moose::Util::MetaRole; + + use Test::More; + use Test::Fatal; + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { instance => ['MooseX::SomeAwesomeDBFields'] }, + ); + + is( exception { + has lazy_attr => ( + is => 'ro', + isa => 'Bool', + lazy => 1, + default => sub {0}, + ); + }, undef, "Adding lazy accessor does not use inline_slot_access" ); + + is( exception { + has rw_attr => ( + is => 'rw', + ); + }, undef, "Adding read-write accessor does not use inline_slot_access" ); + + is( exception { __PACKAGE__->meta->make_immutable; }, undef, "Inling constructor does not use inline_slot_access" ); + + done_testing; +} diff --git a/t/attributes/non_alpha_attr_names.t b/t/attributes/non_alpha_attr_names.t new file mode 100644 index 0000000..f710c88 --- /dev/null +++ b/t/attributes/non_alpha_attr_names.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + has 'type' => ( + required => 0, + reader => 'get_type', + default => 1, + ); + + # Assigning types to these non-alpha attrs exposed a bug in Moose. + has '@type' => ( + isa => 'Str', + required => 0, + reader => 'get_at_type', + writer => 'set_at_type', + default => 'at type', + ); + + has 'has spaces' => ( + isa => 'Int', + required => 0, + reader => 'get_hs', + default => 42, + ); + + has '!req' => ( + required => 1, + reader => 'req' + ); + + no Moose; +} + +with_immutable { + ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" ) + for 'type', '@type', 'has spaces'; + + my $foo = Foo->new( '!req' => 42 ); + + is( $foo->get_type, 1, q{'type' attribute default is 1} ); + is( $foo->get_at_type, 'at type', q{'@type' attribute default is 1} ); + is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} ); + + $foo = Foo->new( + type => 'foo', + '@type' => 'bar', + 'has spaces' => 200, + '!req' => 84, + ); + + isa_ok( $foo, 'Foo' ); + is( $foo->get_at_type, 'bar', q{reader for '@type'} ); + is( $foo->get_hs, 200, q{reader for 'has spaces'} ); + + $foo->set_at_type(99); + is( $foo->get_at_type, 99, q{writer for '@type' worked} ); +} +'Foo'; + +done_testing; diff --git a/t/attributes/numeric_defaults.t b/t/attributes/numeric_defaults.t new file mode 100644 index 0000000..0691cde --- /dev/null +++ b/t/attributes/numeric_defaults.t @@ -0,0 +1,130 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use B; + +{ + package Foo; + use Moose; + + has foo => (is => 'ro', default => 100); + + sub bar { 100 } +} + +with_immutable { + my $foo = Foo->new; + for my $meth (qw(foo bar)) { + my $val = $foo->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Foo'; + +{ + package Bar; + use Moose; + + has foo => (is => 'ro', lazy => 1, default => 100); + + sub bar { 100 } +} + +with_immutable { + my $bar = Bar->new; + for my $meth (qw(foo bar)) { + my $val = $bar->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Bar'; + +{ + package Baz; + use Moose; + + has foo => (is => 'ro', isa => 'Int', lazy => 1, default => 100); + + sub bar { 100 } +} + +with_immutable { + my $baz = Baz->new; + for my $meth (qw(foo bar)) { + my $val = $baz->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Baz'; + +{ + package Foo2; + use Moose; + + has foo => (is => 'ro', default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $foo2 = Foo2->new; + for my $meth (qw(foo bar)) { + my $val = $foo2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Foo2'; + +{ + package Bar2; + use Moose; + + has foo => (is => 'ro', lazy => 1, default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $bar2 = Bar2->new; + for my $meth (qw(foo bar)) { + my $val = $bar2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Bar2'; + +{ + package Baz2; + use Moose; + + has foo => (is => 'ro', isa => 'Num', lazy => 1, default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $baz2 = Baz2->new; + for my $meth (qw(foo bar)) { + my $val = $baz2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + # it's making sure that the Num value doesn't get converted to a string for regex matching + # this is the reason for using a temporary variable, $val for regex matching, + # instead of $_[1] in Num implementation in lib/Moose/Util/TypeConstraints/Builtins.pm + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Baz2'; + +done_testing; diff --git a/t/attributes/trigger_and_coerce.t b/t/attributes/trigger_and_coerce.t new file mode 100644 index 0000000..d28b7ce --- /dev/null +++ b/t/attributes/trigger_and_coerce.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + + +{ + + package Fake::DateTime; + use Moose; + + has 'string_repr' => ( is => 'ro' ); + + package Mortgage; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Fake::DateTime' => from 'Str' => + via { Fake::DateTime->new( string_repr => $_ ) }; + + has 'closing_date' => ( + is => 'rw', + isa => 'Fake::DateTime', + coerce => 1, + trigger => sub { + my ( $self, $val ) = @_; + ::pass('... trigger is being called'); + ::isa_ok( $self->closing_date, 'Fake::DateTime' ); + ::isa_ok( $val, 'Fake::DateTime' ); + } + ); +} + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + isa_ok( $mtg, 'Mortgage' ); + + # check that coercion worked + isa_ok( $mtg->closing_date, 'Fake::DateTime' ); +} + +Mortgage->meta->make_immutable; +ok( Mortgage->meta->is_immutable, '... Mortgage is now immutable' ); + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + isa_ok( $mtg, 'Mortgage' ); + + # check that coercion worked + isa_ok( $mtg->closing_date, 'Fake::DateTime' ); +} + +done_testing; diff --git a/t/attributes/type_constraint.t b/t/attributes/type_constraint.t new file mode 100644 index 0000000..16bc981 --- /dev/null +++ b/t/attributes/type_constraint.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package AttrHasTC; + use Moose; + has foo => ( + is => 'ro', + isa => 'Int', + ); + + has bar => ( + is => 'ro', + ); +} + +ok( + AttrHasTC->meta->get_attribute('foo')->verify_against_type_constraint(42), + 'verify_against_type_constraint returns true with valid Int' +); + +my $e = exception { + AttrHasTC->meta->get_attribute('foo') + ->verify_against_type_constraint('foo'); +}; + +isa_ok( + $e, + 'Moose::Exception::ValidationFailedForTypeConstraint', + 'exception thrown when verify_against_type_constraint fails' +); + +ok( + AttrHasTC->meta->get_attribute('bar')->verify_against_type_constraint(42), + 'verify_against_type_constraint returns true when attr has no TC' +); + +done_testing; diff --git a/t/basics/always_strict_warnings.t b/t/basics/always_strict_warnings.t new file mode 100644 index 0000000..ca62682 --- /dev/null +++ b/t/basics/always_strict_warnings.t @@ -0,0 +1,71 @@ +use Test::More; + +# very intentionally not doing use strict; use warnings here... + +# for classes ... +{ + package Foo; + use Moose; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for roles ... +{ + package Bar; + use Moose::Role; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for exporters +{ + package Bar; + use Moose::Exporter; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +done_testing; diff --git a/t/basics/basic_class_setup.t b/t/basics/basic_class_setup.t new file mode 100644 index 0000000..64a5779 --- /dev/null +++ b/t/basics/basic_class_setup.t @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'Moose::Meta::Class'); + +ok(Foo->meta->has_method('meta'), '... we got the &meta method'); +ok(Foo->isa('Moose::Object'), '... Foo is automagically a Moose::Object'); + +isnt( exception { + Foo->meta->has_method() +}, undef, '... has_method requires an arg' ); + +can_ok('Foo', 'does'); + +foreach my $function (qw( + extends + has + before after around + blessed confess + type subtype as where + coerce from via + find_type_constraint + )) { + ok(!Foo->meta->has_method($function), '... the meta does not treat "' . $function . '" as a method'); +} + +foreach my $import (qw( + blessed + try + catch + in_global_destruction +)) { + ok(!Moose::Object->can($import), "no namespace pollution in Moose::Object ($import)" ); + + local $TODO = $import eq 'blessed' ? "no automatic namespace cleaning yet" : undef; + ok(!Foo->can($import), "no namespace pollution in Moose::Object ($import)" ); +} + +done_testing; diff --git a/t/basics/buildargs.t b/t/basics/buildargs.t new file mode 100644 index 0000000..f7b5b5d --- /dev/null +++ b/t/basics/buildargs.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $self, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return {@args}; + } + + package Bar; + use Moose; + + extends qw(Foo); +} + +foreach my $class (qw(Foo Bar)) { + is( $class->new->bar, undef, "no args" ); + is( $class->new( bar => 42 )->bar, 42, "normal args" ); + is( $class->new( 37 )->bar, 37, "single arg" ); + { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } +} + +done_testing; diff --git a/t/basics/buildargs_warning.t b/t/basics/buildargs_warning.t new file mode 100644 index 0000000..5b1a415 --- /dev/null +++ b/t/basics/buildargs_warning.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; +use Test::Moose qw( with_immutable ); + +use Test::Requires 'Test::Output'; + +{ + package Baz; + use Moose; +} + +with_immutable { + is( exception { + stderr_like { Baz->new( x => 42, 'y' ) } + qr{\QThe new() method for Baz expects a hash reference or a key/value list. You passed an odd number of arguments at $0 line \E\d+}, + 'warning when passing an odd number of args to new()'; + + stderr_unlike { Baz->new( x => 42, 'y' ) } + qr{\QOdd number of elements in anonymous hash}, + 'we suppress the standard warning from Perl for an odd number of elements in a hash'; + + stderr_is { Baz->new( { x => 42 } ) } + q{}, + 'we handle a single hashref to new without errors'; + }, undef ); +} +'Baz'; + +done_testing; diff --git a/t/basics/create.t b/t/basics/create.t new file mode 100644 index 0000000..37dcf57 --- /dev/null +++ b/t/basics/create.t @@ -0,0 +1,61 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::Load 'is_class_loaded'; + +{ + package Class; + use Moose; + + package Foo; + use Moose::Role; + sub foo_role_applied { 1 } + + package Conflicts::With::Foo; + use Moose::Role; + sub foo_role_applied { 0 } + + package Not::A::Role; + sub lol_wut { 42 } +} + +my $new_class; + +is( exception { + $new_class = Moose::Meta::Class->create( + 'Class::WithFoo', + superclasses => ['Class'], + roles => ['Foo'], + ); +}, undef, 'creating lives' ); +ok $new_class; + +my $with_foo = Class::WithFoo->new; + +ok $with_foo->foo_role_applied; +isa_ok $with_foo, 'Class', '$with_foo'; + +like( exception { + Moose::Meta::Class->create( + 'Made::Of::Fail', + superclasses => ['Class'], + roles => 'Foo', # "oops" + ); +}, qr/You must pass an ARRAY ref of roles/ ); + +ok !is_class_loaded('Made::Of::Fail'), "did not create Made::Of::Fail"; + +isnt( exception { + Moose::Meta::Class->create( + 'Continuing::To::Fail', + superclasses => ['Class'], + roles => ['Foo', 'Conflicts::With::Foo'], + ); +}, undef, 'conflicting roles == death' ); + +# XXX: Continuing::To::Fail gets created anyway + +done_testing; diff --git a/t/basics/create_anon.t b/t/basics/create_anon.t new file mode 100644 index 0000000..b36b2a8 --- /dev/null +++ b/t/basics/create_anon.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Meta::Class; + +{ + package Class; + use Moose; + + package Foo; + use Moose::Role; + sub foo_role_applied { 1 } + + package Bar; + use Moose::Role; + sub bar_role_applied { 1 } +} + +# try without caching first + +{ + my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + my $class_and_foo_2 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + isnt $class_and_foo_1->name, $class_and_foo_2->name, + 'creating the same class twice without caching results in 2 classes'; + + map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); +} + +# now try with caching + +{ + my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + my $class_and_foo_2 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + is $class_and_foo_1->name, $class_and_foo_2->name, + 'with cache, the same class is the same class'; + + map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); + + my $class_and_bar = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Bar'], + cache => 1, + ); + + isnt $class_and_foo_1->name, $class_and_bar, + 'class_and_foo and class_and_bar are different'; + + ok $class_and_bar->name->bar_role_applied; +} + +# This tests that a cached metaclass can be reinitialized and still retain its +# metaclass object. +{ + my $name = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + )->name; + + $name->meta->reinitialize( $name ); + + can_ok( $name, 'meta' ); +} + +{ + my $name; + { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + ); + $name = $meta->name; + ok(!Class::MOP::metaclass_is_weak($name), "cache implies weaken => 0"); + } + ok(Class::MOP::class_of($name), "cache implies weaken => 0"); + Class::MOP::remove_metaclass_by_name($name); +} + +{ + my $name; + { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + weaken => 1, + ); + my $name = $meta->name; + ok(Class::MOP::metaclass_is_weak($name), "but we can override this"); + } + ok(!Class::MOP::class_of($name), "but we can override this"); +} + +{ + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + ); + ok(!Class::MOP::metaclass_is_weak($meta->name), + "creates a nonweak metaclass"); + Scalar::Util::weaken($meta); + Class::MOP::remove_metaclass_by_name($meta->name); + ok(!$meta, "removing a cached anon class means it's actually gone"); +} + +done_testing; diff --git a/t/basics/deprecations.t b/t/basics/deprecations.t new file mode 100644 index 0000000..1eb7a9c --- /dev/null +++ b/t/basics/deprecations.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Util::TypeConstraints; + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + enum Foo => qw(Bar Baz Quux); + like($warnings, qr/Passing a list of values to enum is deprecated\. Enum values should be wrapped in an arrayref\./); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + duck_type Bar => qw(baz quux); + like($warnings, qr/Passing a list of values to duck_type is deprecated\. The method names should be wrapped in an arrayref\./); +} + +done_testing; diff --git a/t/basics/destruction.t b/t/basics/destruction.t new file mode 100644 index 0000000..55cb78e --- /dev/null +++ b/t/basics/destruction.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +our @demolished; +package Foo; +use Moose; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub; +use Moose; +extends 'Foo'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub::Sub; +use Moose; +extends 'Foo::Sub'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package main; +{ + my $foo = Foo->new; +} +is_deeply(\@demolished, ['Foo'], "Foo demolished properly"); +@demolished = (); +{ + my $foo_sub = Foo::Sub->new; +} +is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly"); +@demolished = (); +{ + my $foo_sub_sub = Foo::Sub::Sub->new; +} +is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'], + "Foo::Sub::Sub demolished properly"); +@demolished = (); + +done_testing; diff --git a/t/basics/error_handling.t b/t/basics/error_handling.t new file mode 100644 index 0000000..250aa30 --- /dev/null +++ b/t/basics/error_handling.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# This tests the error handling in Moose::Object only + +{ + package Foo; + use Moose; +} + +like( exception { Foo->new('bad') }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); +like( exception { Foo->new(undef) }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); + +like( exception { Foo->does() }, qr/^\QYou must supply a role name to does()/, 'Cannot call does() without a role name' ); + +done_testing; diff --git a/t/basics/global-destruction-helper.pl b/t/basics/global-destruction-helper.pl new file mode 100644 index 0000000..a5b75c6 --- /dev/null +++ b/t/basics/global-destruction-helper.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + + +{ + package Foo; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } +} + +{ + package Bar; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } + + __PACKAGE__->meta->make_immutable; +} + +our $foo = Foo->new; +our $bar = Bar->new; diff --git a/t/basics/global_destruction.t b/t/basics/global_destruction.t new file mode 100644 index 0000000..53a4db1 --- /dev/null +++ b/t/basics/global_destruction.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok( + !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)' + ); + } +} + +{ + my $foo = Foo->new; +} + +{ + package Bar; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok( + !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)' + ); + } + + __PACKAGE__->meta->make_immutable; +} + +{ + my $bar = Bar->new; +} + +ok( + $_, + 'in_global_destruction state is passed to DEMOLISH properly (true)' +) for split //, `$^X t/basics/global-destruction-helper.pl`; + +done_testing; diff --git a/t/basics/import_unimport.t b/t/basics/import_unimport.t new file mode 100644 index 0000000..b44fea7 --- /dev/null +++ b/t/basics/import_unimport.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; + + +my @moose_exports = qw( + extends with + has + before after around + override + augment + super inner + blessed confess +); + +{ + package Foo; + + eval 'use Moose'; + die $@ if $@; +} + +can_ok('Foo', $_) for @moose_exports; + +{ + package Foo; + + eval 'no Moose'; + die $@ if $@; +} + +ok(!Foo->can($_), '... Foo can no longer do ' . $_) for @moose_exports; + +# and check the type constraints as well + +my @moose_type_constraint_exports = qw( + type subtype as where message + coerce from via + enum + find_type_constraint +); + +{ + package Bar; + + eval 'use Moose::Util::TypeConstraints'; + die $@ if $@; +} + +can_ok('Bar', $_) for @moose_type_constraint_exports; + +{ + package Bar; + + eval 'no Moose::Util::TypeConstraints'; + die $@ if $@; +} + +ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports; + + +{ + package Baz; + + use Moose; + use Scalar::Util qw( blessed ); + + no Moose; +} + +can_ok( 'Baz', 'blessed' ); + +{ + package Moo; + + use Scalar::Util qw( blessed ); + use Moose; + + no Moose; +} + +can_ok( 'Moo', 'blessed' ); + +my $blessed; +{ + package Quux; + + use Scalar::Util qw( blessed ); + use Moose blessed => { -as => \$blessed }; + + no Moose; +} + +can_ok( 'Quux', 'blessed' ); +is( $blessed, \&Scalar::Util::blessed ); + +done_testing; diff --git a/t/basics/inner_and_augment.t b/t/basics/inner_and_augment.t new file mode 100644 index 0000000..c343c38 --- /dev/null +++ b/t/basics/inner_and_augment.t @@ -0,0 +1,117 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' } + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + sub baz { 'Foo::baz(' . (inner() || '') . ')' } + + package Bar; + use Moose; + + extends 'Foo'; + + augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' }; + augment bar => sub { 'Bar::bar' }; + + no Moose; # ensure inner() still works after unimport + + package Baz; + use Moose; + + extends 'Bar'; + + augment foo => sub { 'Baz::foo' }; + augment baz => sub { 'Baz::baz' }; + + # this will actually never run, + # because Bar::bar does not call inner() + augment bar => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo'); +is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); +is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo(Bar::foo())', '... got the right value from &foo'); +is($bar->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz()', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo()', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar()', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz()', '... got the right value from &baz'); + +# test saved state when crossing objects + +{ + package X; + use Moose; + has name => (is => 'rw'); + sub run { + "$_[0]->{name}.X", inner() + } + + package Y; + use Moose; + extends 'X'; + augment 'run' => sub { + "$_[0]->{name}.Y", ($_[1] ? $_[1]->() : ()), inner(); + }; + + package Z; + use Moose; + extends 'Y'; + augment 'run' => sub { + "$_[0]->{name}.Z" + } +} + +is('a.X a.Y b.X b.Y b.Z a.Z', + do { + my $a = Z->new(name => 'a'); + my $b = Z->new(name => 'b'); + join(' ', $a->run(sub { $b->run })) + }, + 'State is saved when cross-calling augmented methods on different objects'); + +# some error cases + +{ + package Bling; + use Moose; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::isnt( ::exception { + augment 'bling' => sub {}; + }, undef, '... cannot augment a method which has a local equivalent' ); + +} + +done_testing; diff --git a/t/basics/load_into_main.t b/t/basics/load_into_main.t new file mode 100644 index 0000000..ddfb834 --- /dev/null +++ b/t/basics/load_into_main.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +is( exception { + eval 'use Moose'; +}, undef, "export to main" ); + +isa_ok( main->meta, "Moose::Meta::Class" ); + +isa_ok( main->new, "main"); +isa_ok( main->new, "Moose::Object" ); + +done_testing; diff --git a/t/basics/method_modifier_with_regexp.t b/t/basics/method_modifier_with_regexp.t new file mode 100644 index 0000000..8f9319b --- /dev/null +++ b/t/basics/method_modifier_with_regexp.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Dog; + use Moose; + + sub bark_once { + my $self = shift; + return 'bark'; + } + + sub bark_twice { + return 'barkbark'; + } + + around qr/bark.*/ => sub { + 'Dog::around(' . $_[0]->() . ')'; + }; + +} + +my $dog = Dog->new; +is( $dog->bark_once, 'Dog::around(bark)', 'around modifier is called' ); +is( $dog->bark_twice, 'Dog::around(barkbark)', 'around modifier is called' ); + +{ + + package Cat; + use Moose; + our $BEFORE_BARK_COUNTER = 0; + our $AFTER_BARK_COUNTER = 0; + + sub bark_once { + my $self = shift; + return 'bark'; + } + + sub bark_twice { + return 'barkbark'; + } + + before qr/bark.*/ => sub { + $BEFORE_BARK_COUNTER++; + }; + + after qr/bark.*/ => sub { + $AFTER_BARK_COUNTER++; + }; + +} + +my $cat = Cat->new; +$cat->bark_once; +is( $Cat::BEFORE_BARK_COUNTER, 1, 'before modifier is called once' ); +is( $Cat::AFTER_BARK_COUNTER, 1, 'after modifier is called once' ); +$cat->bark_twice; +is( $Cat::BEFORE_BARK_COUNTER, 2, 'before modifier is called twice' ); +is( $Cat::AFTER_BARK_COUNTER, 2, 'after modifier is called twice' ); + +{ + package Dog::Role; + use Moose::Role; + + ::isnt( ::exception { + before qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + + ::isnt( ::exception { + around qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + + ::isnt( ::exception { + after qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + +} + +done_testing; diff --git a/t/basics/methods.t b/t/basics/methods.t new file mode 100644 index 0000000..da34a07 --- /dev/null +++ b/t/basics/methods.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; + + +my $test1 = Moose::Meta::Class->create_anon_class; +$test1->add_method( 'foo1', sub { } ); + +my $t1 = $test1->new_object; +my $t1_am = $t1->meta->get_method('foo1')->associated_metaclass; + +ok( $t1_am, 'associated_metaclass is defined' ); + +isa_ok( + $t1_am, 'Moose::Meta::Class', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Moose; + + sub foo2 { } +} + +my $t2 = Test2->new; +my $t2_am = $t2->meta->get_method('foo2')->associated_metaclass; + +ok( $t2_am, 'associated_metaclass is defined' ); + +isa_ok( + $t2_am, 'Moose::Meta::Class', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); + +done_testing; diff --git a/t/basics/moose_object_does.t b/t/basics/moose_object_does.t new file mode 100644 index 0000000..87338af --- /dev/null +++ b/t/basics/moose_object_does.t @@ -0,0 +1,158 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Role::A; + use Moose::Role +} + +{ + package Role::B; + use Moose::Role +} + +{ + package Foo; + use Moose; +} + +{ + package Bar; + use Moose; + + with 'Role::A'; +} + +{ + package Baz; + use Moose; + + with qw( Role::A Role::B ); +} + +{ + package Foo::Child; + use Moose; + + extends 'Foo'; +} + +{ + package Bar::Child; + use Moose; + + extends 'Bar'; +} + +{ + package Baz::Child; + use Moose; + + extends 'Baz'; +} + +with_immutable { + + for my $thing ( 'Foo', Foo->new, 'Foo::Child', Foo::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + !$thing->does('Role::A'), + "$name does not do Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + !$thing->does( Role::A->meta ), + "$name does not do Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + !$thing->DOES('Role::A'), + "$name does not do Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Bar', Bar->new, 'Bar::Child', Bar::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Baz', Baz->new, 'Baz::Child', Baz::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + $thing->does('Role::B'), + "$name does Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + $thing->does( Role::B->meta ), + "$name does Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + $thing->DOES('Role::B'), + "$name does Role::B (using DOES)" + ); + } + +} +qw( Foo Bar Baz Foo::Child Bar::Child Baz::Child ); + +done_testing; diff --git a/t/basics/moose_respects_type_constraints.t b/t/basics/moose_respects_type_constraints.t new file mode 100644 index 0000000..5dba161 --- /dev/null +++ b/t/basics/moose_respects_type_constraints.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +=pod + +This tests demonstrates that Moose will not override +a preexisting type constraint of the same name when +making constraints for a Moose-class. + +It also tests that an attribute which uses a 'Foo' for +its isa option will get the subtype Foo, and not a +type representing the Foo moose class. + +=cut + +BEGIN { + # create this subtype first (in BEGIN) + subtype Foo + => as 'Value' + => where { $_ eq 'Foo' }; +} + +{ # now seee if Moose will override it + package Foo; + use Moose; +} + +my $foo_constraint = find_type_constraint('Foo'); +isa_ok($foo_constraint, 'Moose::Meta::TypeConstraint'); + +is($foo_constraint->parent->name, 'Value', '... got the Value subtype for Foo'); + +ok($foo_constraint->check('Foo'), '... my constraint passed correctly'); +ok(!$foo_constraint->check('Bar'), '... my constraint failed correctly'); + +{ + package Bar; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +is( exception { + $bar->foo('Foo'); +}, undef, '... checked the type constraint correctly' ); + +isnt( exception { + $bar->foo(Foo->new); +}, undef, '... checked the type constraint correctly' ); + +done_testing; diff --git a/t/basics/override_and_foreign_classes.t b/t/basics/override_and_foreign_classes.t new file mode 100644 index 0000000..f671fe9 --- /dev/null +++ b/t/basics/override_and_foreign_classes.t @@ -0,0 +1,72 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This just tests the interaction of override/super +with non-Moose superclasses. It really should not +cause issues, the only thing it does is to create +a metaclass for Foo so that it can find the right +super method. + +This may end up being a sensitive issue for some +non-Moose classes, but in 99% of the cases it +should be just fine. + +=cut + +{ + package Foo; + use strict; + use warnings; + + sub new { bless {} => shift() } + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); + +done_testing; diff --git a/t/basics/override_augment_inner_super.t b/t/basics/override_augment_inner_super.t new file mode 100644 index 0000000..7ec35ea --- /dev/null +++ b/t/basics/override_augment_inner_super.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + + package Bar; + use Moose; + + extends 'Foo'; + + augment 'foo' => sub { 'Bar::foo' }; + override 'bar' => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override 'foo' => sub { 'Baz::foo -> ' . super() }; + augment 'bar' => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +=pod + +Let em clarify what is happening here. Baz::foo is calling +super(), which calls Bar::foo, which is an augmented sub +that calls Foo::foo, then calls inner() which actually +then calls Bar::foo. Confusing I know,.. but this is +*exactly* what is it supposed to do :) + +=cut + +is($baz->foo, + 'Baz::foo -> Foo::foo(Bar::foo)', + '... got the right value from mixed augment/override foo'); + +=pod + +Allow me to clarify this one now ... + +Since Baz::bar is an augment routine, it needs to find the +correct inner() to be called by. In this case it is Foo::bar. +However, Bar::bar is in-between us, so it should actually be +called first. Bar::bar is an overriden sub, and calls super() +which in turn then calls our Foo::bar, which calls inner(), +which calls Baz::bar. + +Confusing I know, but it is correct :) + +=cut + +is($baz->bar, + 'Bar::bar -> Foo::bar(Baz::bar)', + '... got the right value from mixed augment/override bar'); + +done_testing; diff --git a/t/basics/rebless.t b/t/basics/rebless.t new file mode 100644 index 0000000..db08d6b --- /dev/null +++ b/t/basics/rebless.t @@ -0,0 +1,136 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose qw(with_immutable); +use Scalar::Util 'blessed'; + +use Moose::Util::TypeConstraints; + +subtype 'Positive' + => as 'Num' + => where { $_ > 0 }; + +{ + package Parent; + use Moose; + + has name => ( + is => 'rw', + isa => 'Str', + ); + + has lazy_classname => ( + is => 'ro', + lazy => 1, + default => sub { "Parent" }, + ); + + has type_constrained => ( + is => 'rw', + isa => 'Num', + default => 5.5, + ); + + package Child; + use Moose; + extends 'Parent'; + + has '+name' => ( + default => 'Junior', + ); + + has '+lazy_classname' => ( + default => sub {"Child"}, + ); + + has '+type_constrained' => ( + isa => 'Int', + default => 100, + ); + + our %trigger_calls; + our %initializer_calls; + + has new_attr => ( + is => 'rw', + isa => 'Str', + trigger => sub { + my ( $self, $val, $attr ) = @_; + $trigger_calls{new_attr}++; + }, + initializer => sub { + my ( $self, $value, $set, $attr ) = @_; + $initializer_calls{new_attr}++; + $set->($value); + }, + ); +} + +my @classes = qw(Parent Child); + +with_immutable { + my $foo = Parent->new; + my $bar = Parent->new; + + is( blessed($foo), 'Parent', 'Parent->new gives a Parent object' ); + is( $foo->name, undef, 'No name yet' ); + is( $foo->lazy_classname, 'Parent', "lazy attribute initialized" ); + is( + exception { $foo->type_constrained(10.5) }, undef, + "Num type constraint for now.." + ); + + # try to rebless, except it will fail due to Child's stricter type constraint + like( + exception { Child->meta->rebless_instance($foo) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, + '... this failed because of type check' + ); + like( + exception { Child->meta->rebless_instance($bar) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, + '... this failed because of type check' + ); + + $foo->type_constrained(10); + $bar->type_constrained(5); + + Child->meta->rebless_instance($foo); + Child->meta->rebless_instance( $bar, new_attr => 'blah' ); + + is( blessed($foo), 'Child', 'successfully reblessed into Child' ); + is( $foo->name, 'Junior', "Child->name's default came through" ); + + is( + $foo->lazy_classname, 'Parent', + "lazy attribute was already initialized" + ); + is( + $bar->lazy_classname, 'Child', + "lazy attribute just now initialized" + ); + + like( + exception { $foo->type_constrained(10.5) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, + '... this failed because of type check' + ); + + is_deeply( + \%Child::trigger_calls, { new_attr => 1 }, + 'Trigger fired on rebless_instance' + ); + is_deeply( + \%Child::initializer_calls, { new_attr => 1 }, + 'Initializer fired on rebless_instance' + ); + + undef %Child::trigger_calls; + undef %Child::initializer_calls; + +} +@classes; + +done_testing; diff --git a/t/basics/require_superclasses.t b/t/basics/require_superclasses.t new file mode 100644 index 0000000..f2b1683 --- /dev/null +++ b/t/basics/require_superclasses.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + + +{ + + package Bar; + use Moose; + + ::is( ::exception { extends 'Foo' }, undef, 'loaded Foo superclass correctly' ); +} + +{ + + package Baz; + use Moose; + + ::is( ::exception { extends 'Bar' }, undef, 'loaded (inline) Bar superclass correctly' ); +} + +{ + + package Foo::Bar; + use Moose; + + ::is( ::exception { extends 'Foo', 'Bar' }, undef, 'loaded Foo and (inline) Bar superclass correctly' ); +} + +{ + + package Bling; + use Moose; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + ::is( ::exception { extends 'No::Class' }, undef, "extending an empty package is a valid thing to do" ); + ::like( $warnings, qr/^Can't locate package No::Class for \@Bling::ISA/, "but it does give a warning" ); +} + +{ + package Affe; + our $VERSION = 23; +} + +{ + package Tiger; + use Moose; + + ::is( ::exception { extends 'Foo', Affe => { -version => 13 } }, undef, 'extends with version requirement' ); +} + +{ + package Birne; + use Moose; + + ::like( ::exception { extends 'Foo', Affe => { -version => 42 } }, qr/Affe version 42 required--this is only version 23/, 'extends with unsatisfied version requirement' ); +} + +done_testing; diff --git a/t/basics/super_and_override.t b/t/basics/super_and_override.t new file mode 100644 index 0000000..edebc71 --- /dev/null +++ b/t/basics/super_and_override.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; + + no Moose; # ensure super() still works after unimport +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); + +# some error cases + +{ + package Bling; + use Moose; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::isnt( ::exception { + override 'bling' => sub {}; + }, undef, '... cannot override a method which has a local equivalent' ); + +} + +done_testing; diff --git a/t/basics/super_warns_on_args.t b/t/basics/super_warns_on_args.t new file mode 100644 index 0000000..3600d9f --- /dev/null +++ b/t/basics/super_warns_on_args.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::Requires 'Test::Output'; +use Test::More; + +{ + package Parent; + use Moose; + + sub foo { 42 } + sub bar { 42 } + + package Child; + use Moose; + + extends 'Parent'; + + override foo => sub { + super( 1, 2, 3 ); + }; + + override bar => sub { + super(); + }; +} + +{ + my $file = __FILE__; + + stderr_like( + sub { Child->new->foo }, + qr/\QArguments passed to super() are ignored at $file/, + 'got a warning when passing args to super() call' + ); + + stderr_is( + sub { Child->new->bar }, + q{}, + 'no warning on super() call without arguments' + ); +} + +done_testing(); diff --git a/t/basics/universal_methods_wrappable.t b/t/basics/universal_methods_wrappable.t new file mode 100644 index 0000000..350688c --- /dev/null +++ b/t/basics/universal_methods_wrappable.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + + package FakeBar; + use Moose::Role; + + around isa => sub { + my ( $orig, $self, $v ) = @_; + return 1 if $v eq 'Bar'; + return $orig->( $self, $v ); + }; + + package Foo; + use Moose; + + use Test::More; + + ::is( ::exception { with 'FakeBar' }, undef, 'applied role' ); + + my $foo = Foo->new; + ::isa_ok( $foo, 'Bar' ); +} + +done_testing; diff --git a/t/basics/wrapped_method_cxt_propagation.t b/t/basics/wrapped_method_cxt_propagation.t new file mode 100644 index 0000000..ce1e243 --- /dev/null +++ b/t/basics/wrapped_method_cxt_propagation.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package TouchyBase; + use Moose; + + has x => ( is => 'rw', default => 0 ); + + sub inc { $_[0]->x( 1 + $_[0]->x ) } + + sub scalar_or_array { + wantarray ? (qw/a b c/) : "x"; + } + + sub void { + die "this must be void context" if defined wantarray; + } + + package AfterSub; + use Moose; + + extends "TouchyBase"; + + after qw/scalar_or_array void/ => sub { + my $self = shift; + $self->inc; + } +} + +my $base = TouchyBase->new; +my $after = AfterSub->new; + +foreach my $obj ( $base, $after ) { + my $class = ref $obj; + my @array = $obj->scalar_or_array; + my $scalar = $obj->scalar_or_array; + + is_deeply(\@array, [qw/a b c/], "array context ($class)"); + is($scalar, "x", "scalar context ($class)"); + + { + local $@; + eval { $obj->void }; + ok( !$@, "void context ($class)" ); + } + + if ( $obj->isa("AfterSub") ) { + is( $obj->x, 3, "methods were wrapped" ); + } +} + +done_testing; diff --git a/t/bugs/DEMOLISHALL.t b/t/bugs/DEMOLISHALL.t new file mode 100644 index 0000000..43d831e --- /dev/null +++ b/t/bugs/DEMOLISHALL.t @@ -0,0 +1,54 @@ +use strict; +use warnings; +use Test::More; + +my @called; + +do { + package Class; + use Moose; + + sub DEMOLISH { + push @called, 'Class::DEMOLISH'; + } + + sub DEMOLISHALL { + my $self = shift; + push @called, 'Class::DEMOLISHALL'; + $self->SUPER::DEMOLISHALL(@_); + } + + package Child; + use Moose; + extends 'Class'; + + sub DEMOLISH { + push @called, 'Child::DEMOLISH'; + } + + sub DEMOLISHALL { + my $self = shift; + push @called, 'Child::DEMOLISHALL'; + $self->SUPER::DEMOLISHALL(@_); + } +}; + +is_deeply([splice @called], [], "no DEMOLISH calls yet"); + +do { + my $object = Class->new; + + is_deeply([splice @called], [], "no DEMOLISH calls yet"); +}; + +is_deeply([splice @called], ['Class::DEMOLISHALL', 'Class::DEMOLISH']); + +do { + my $child = Child->new; + is_deeply([splice @called], [], "no DEMOLISH calls yet"); + +}; + +is_deeply([splice @called], ['Child::DEMOLISHALL', 'Class::DEMOLISHALL', 'Child::DEMOLISH', 'Class::DEMOLISH']); + +done_testing; diff --git a/t/bugs/DEMOLISHALL_shortcutted.t b/t/bugs/DEMOLISHALL_shortcutted.t new file mode 100644 index 0000000..9095791 --- /dev/null +++ b/t/bugs/DEMOLISHALL_shortcutted.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +## This test ensures that sub DEMOLISHALL fires even if there is no sub DEMOLISH +## Currently fails because of a bad optimization in DESTROY +## Feb 12, 2009 -- Evan Carroll me@evancarroll.com +package Role::DemolishAll; +use Moose::Role; +our $ok = 0; + +sub BUILD { $ok = 0 }; +after 'DEMOLISHALL' => sub { $Role::DemolishAll::ok++ }; + +package DemolishAll::WithoutDemolish; +use Moose; +with 'Role::DemolishAll'; + +package DemolishAll::WithDemolish; +use Moose; +with 'Role::DemolishAll'; +sub DEMOLISH {}; + + +package main; +use Test::More; + +my $m = DemolishAll::WithDemolish->new; +undef $m; +is ( $Role::DemolishAll::ok, 1, 'DemolishAll w/ explicit DEMOLISH sub' ); + +$m = DemolishAll::WithoutDemolish->new; +undef $m; +is ( $Role::DemolishAll::ok, 1, 'DemolishAll wo/ explicit DEMOLISH sub' ); + +done_testing; diff --git a/t/bugs/DEMOLISH_eats_exceptions.t b/t/bugs/DEMOLISH_eats_exceptions.t new file mode 100644 index 0000000..c8e9bb1 --- /dev/null +++ b/t/bugs/DEMOLISH_eats_exceptions.t @@ -0,0 +1,149 @@ +use strict; +use warnings; +use FindBin; + +use Test::More; + +use Moose::Util::TypeConstraints; + +subtype 'FilePath' + => as 'Str' + # This used to try to _really_ check for a valid Unix or Windows + # path, but the regex wasn't quite right, and all we care about + # for the tests is that it rejects '/' + => where { $_ ne '/' }; +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + has 'path' => ( + is => 'ro', + isa => 'FilePath', + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + confess $params->{path} . " does not exist" + unless -e $params->{path}; + } + + # Defining this causes the FIRST call to Baz->new w/o param to fail, + # if no call to ANY Moose::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + } +} + +{ + package Qee; + use Moose; + use Moose::Util::TypeConstraints; + + has 'path' => ( + is => 'ro', + isa => 'FilePath', + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + confess $params->{path} . " does not exist" + unless -e $params->{path}; + } + + # Defining this causes the FIRST call to Qee->new w/o param to fail... + # if no call to ANY Moose::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + } +} + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has 'path' => ( + is => 'ro', + isa => 'FilePath', + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + confess $params->{path} . " does not exist" + unless -e $params->{path}; + } + + # Having no DEMOLISH, everything works as expected... +} + +check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error +check_em ( 'Qee' ); # ok +check_em ( 'Foo' ); # ok + +check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error +check_em ( 'Baz' ); # ok +check_em ( 'Foo' ); # ok + +check_em ( 'Foo' ); # ok +check_em ( 'Baz' ); # ok ! +check_em ( 'Qee' ); # ok + + +sub check_em { + my ( $pkg ) = @_; + my ( %param, $obj ); + + # Uncomment to see, that it is really any first call. + # Subsequents calls will not fail, aka giving the correct error. + { + local $@; + my $obj = eval { $pkg->new; }; + ::like( $@, qr/is required/, "... $pkg plain" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new(); }; + ::like( $@, qr/is required/, "... $pkg empty" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( notanattr => 1 ); }; + ::like( $@, qr/is required/, "... $pkg undef" ); + ::is( $obj, undef, "... the object is undef" ); + } + + { + local $@; + my $obj = eval { $pkg->new ( %param ); }; + ::like( $@, qr/is required/, "... $pkg undef param" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( path => '/' ); }; + ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); }; + ::like( $@, qr/does not exist/, "... $pkg non existing path" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( path => $FindBin::Bin ); }; + ::is( $@, '', "... $pkg no error" ); + ::isa_ok( $obj, $pkg ); + ::isa_ok( $obj, 'Moose::Object' ); + ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" ); + } +} + +done_testing; diff --git a/t/bugs/DEMOLISH_eats_mini.t b/t/bugs/DEMOLISH_eats_mini.t new file mode 100644 index 0000000..ab09e8a --- /dev/null +++ b/t/bugs/DEMOLISH_eats_mini.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + required => 1, + ); + + # Defining this causes the FIRST call to Baz->new w/o param to fail, + # if no call to ANY Moose::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH"; + } +} + +{ + my $obj = eval { Foo->new; }; + like( $@, qr/is required/, "... Foo plain" ); + is( $obj, undef, "... the object is undef" ); +} + +{ + package Bar; + + sub new { die "Bar died"; } + + sub DESTROY { + die "Vanilla Perl eats exceptions in DESTROY too"; + } +} + +{ + my $obj = eval { Bar->new; }; + like( $@, qr/Bar died/, "... Bar plain" ); + is( $obj, undef, "... the object is undef" ); +} + +{ + package Baz; + use Moose; + + sub DEMOLISH { + $? = 0; + } +} + +{ + local $@ = 42; + local $? = 84; + + { + Baz->new; + } + + is( $@, 42, '$@ is still 42 after object is demolished without dying' ); + is( $?, 84, '$? is still 84 after object is demolished without dying' ); + + local $@ = 0; + + { + Baz->new; + } + + is( $@, 0, '$@ is still 0 after object is demolished without dying' ); + + Baz->meta->make_immutable, redo + if Baz->meta->is_mutable +} + +done_testing; diff --git a/t/bugs/DEMOLISH_fails_without_metaclass.t b/t/bugs/DEMOLISH_fails_without_metaclass.t new file mode 100644 index 0000000..b0b0cf4 --- /dev/null +++ b/t/bugs/DEMOLISH_fails_without_metaclass.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package MyClass; + use Moose; + + sub DEMOLISH { } +} + +my $object = MyClass->new; + +# Removing the metaclass simulates the case where the metaclass object +# goes out of scope _before_ the object itself, which under normal +# circumstances only happens during global destruction. +Class::MOP::remove_metaclass_by_name('MyClass'); + +# The bug happened when DEMOLISHALL called +# Class::MOP::class_of($object) and did not get a metaclass object +# back. +is( exception { $object->DESTROY }, undef, 'can call DESTROY on an object without a metaclass object in the CMOP cache' ); + + +MyClass->meta->make_immutable; +Class::MOP::remove_metaclass_by_name('MyClass'); + +# The bug didn't manifest for immutable objects, but this test should +# help us prevent it happening in the future. +is( exception { $object->DESTROY }, undef, 'can call DESTROY on an object without a metaclass object in the CMOP cache (immutable version)' ); + +done_testing; diff --git a/t/bugs/Moose_Object_error.t b/t/bugs/Moose_Object_error.t new file mode 100644 index 0000000..b45f092 --- /dev/null +++ b/t/bugs/Moose_Object_error.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; + +use_ok('MyMooseObject'); + +done_testing; diff --git a/t/bugs/anon_method_metaclass.t b/t/bugs/anon_method_metaclass.t new file mode 100644 index 0000000..01c5285 --- /dev/null +++ b/t/bugs/anon_method_metaclass.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More; + +{ + package Ball; + use Moose; +} + +{ + package Arbitrary::Roll; + use Moose::Role; +} + +my $method_meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Moose::Meta::Method'], + roles => ['Arbitrary::Roll'], +); + +# For comparing identity without actually keeping $original_meta around +my $original_meta = "$method_meta"; + +my $method_class = $method_meta->name; + +my $method_object = $method_class->wrap( + sub {'ok'}, + associated_metaclass => Ball->meta, + package_name => 'Ball', + name => 'bounce', +); + +Ball->meta->add_method( bounce => $method_object ); + +for ( 1, 2 ) { + is( Ball->bounce, 'ok', "method still exists on Ball" ); + is( Ball->meta->get_method('bounce')->meta->name, $method_class, + "method's package still exists" ); + + is( Ball->meta->get_method('bounce'), $method_object, + 'original method object is preserved' ); + + is( Ball->meta->get_method('bounce')->meta . '', $original_meta, + "method's metaclass still exists" ); + ok( Ball->meta->get_method('bounce')->meta->does_role('Arbitrary::Roll'), + "method still does Arbitrary::Roll" ); + + undef $method_meta; +} + +done_testing; diff --git a/t/bugs/application_metarole_compat.t b/t/bugs/application_metarole_compat.t new file mode 100644 index 0000000..70d17a7 --- /dev/null +++ b/t/bugs/application_metarole_compat.t @@ -0,0 +1,56 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +BEGIN { + { + package Foo; + use Moose::Role; + } + + { + package Bar::Class; + use Moose::Role; + } + + { + package Bar::ToClass; + use Moose::Role; + + after apply => sub { + my $self = shift; + my ($role, $class) = @_; + Moose::Util::MetaRole::apply_metaroles( + for => $class, + class_metaroles => { + class => ['Bar::Class'], + } + ); + }; + } + + { + package Bar; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + application_to_class => ['Bar::ToClass'], + } + ); + } +} + +{ + package Parent; + use Moose -traits => 'Foo'; +} + +{ + package Child; + use Moose -traits => 'Bar'; + ::is( ::exception { extends 'Parent' }, undef ); +} + +done_testing; diff --git a/t/bugs/apply_role_to_one_instance_only.t b/t/bugs/apply_role_to_one_instance_only.t new file mode 100644 index 0000000..36df900 --- /dev/null +++ b/t/bugs/apply_role_to_one_instance_only.t @@ -0,0 +1,43 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package MyRole1; + use Moose::Role; + + sub a_role_method { 'foo' } +} + +{ + package MyRole2; + use Moose::Role; + # empty +} + +{ + package Foo; + use Moose; +} + +my $instance_with_role1 = Foo->new; +MyRole1->meta->apply($instance_with_role1); + +my $instance_with_role2 = Foo->new; +MyRole2->meta->apply($instance_with_role2); + +ok ((not $instance_with_role2->does('MyRole1')), + 'instance does not have the wrong role'); + +ok ((not $instance_with_role2->can('a_role_method')), + 'instance does not have methods from the wrong role'); + +ok (($instance_with_role1->does('MyRole1')), + 'role was applied to the correct instance'); + +is( exception { + is $instance_with_role1->a_role_method, 'foo' +}, undef, 'instance has correct role method' ); + +done_testing; diff --git a/t/bugs/attribute_trait_parameters.t b/t/bugs/attribute_trait_parameters.t new file mode 100644 index 0000000..cd053d1 --- /dev/null +++ b/t/bugs/attribute_trait_parameters.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package R; + use Moose::Role; + + sub method { } +} + +{ + package C; + use Moose; + + ::stderr_is{ + has attr => ( + is => 'ro', + traits => [ + R => { ignored => 1 }, + ], + ); + } q{}, 'no warning with foreign parameterized attribute traits'; + + ::stderr_is{ + has alias_attr => ( + is => 'ro', + traits => [ + R => { -alias => { method => 'new_name' } }, + ], + ); + } q{}, 'no warning with -alias parameterized attribute traits'; + + ::stderr_is{ + has excludes_attr => ( + is => 'ro', + traits => [ + R => { -excludes => ['method'] }, + ], + ); + } q{}, 'no warning with -excludes parameterized attribute traits'; +} + +done_testing; diff --git a/t/bugs/augment_recursion_bug.t b/t/bugs/augment_recursion_bug.t new file mode 100644 index 0000000..e55ca5a --- /dev/null +++ b/t/bugs/augment_recursion_bug.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + + package Bar; + use Moose; + + extends 'Foo'; + + package Baz; + use Moose; + + extends 'Foo'; + + my $foo_call_counter; + augment 'foo' => sub { + die "infinite loop on Baz::foo" if $foo_call_counter++ > 1; + return 'Baz::foo and ' . Bar->new->foo; + }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Foo'); + +=pod + +When a subclass which augments foo(), calls a subclass which does not augment +foo(), there is a chance for some confusion. If Moose does not realize that +Bar does not augment foo(), because it is in the call flow of Baz which does, +then we may have an infinite loop. + +=cut + +is($baz->foo, + 'Foo::foo(Baz::foo and Foo::foo())', + '... got the right value for 1 augmented subclass calling non-augmented subclass'); + +done_testing; diff --git a/t/bugs/coerce_without_coercion.t b/t/bugs/coerce_without_coercion.t new file mode 100644 index 0000000..63b74d3 --- /dev/null +++ b/t/bugs/coerce_without_coercion.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo; + + use Moose; + + ::like( + ::exception { + has x => ( + is => 'rw', + isa => 'HashRef', + coerce => 1, + ) + }, + qr/You cannot coerce an attribute \(x\) unless its type \(HashRef\) has a coercion/, + "can't set coerce on an attribute whose type constraint has no coercion" + ); +} + +done_testing; diff --git a/t/bugs/constructor_object_overload.t b/t/bugs/constructor_object_overload.t new file mode 100644 index 0000000..c2d1347 --- /dev/null +++ b/t/bugs/constructor_object_overload.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + use Moose; + + use overload '""' => sub {''}; + + sub bug { 'plenty' } + + __PACKAGE__->meta->make_immutable; +} + +ok(Foo->new()->bug(), 'call constructor on object reference with overloading'); + +done_testing; diff --git a/t/bugs/create_anon_recursion.t b/t/bugs/create_anon_recursion.t new file mode 100644 index 0000000..436048a --- /dev/null +++ b/t/bugs/create_anon_recursion.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +BEGIN { + plan skip_all => "preloading things makes this test meaningless" + if exists $INC{'Moose.pm'}; +} + +use Moose::Meta::Class; + +$SIG{__WARN__} = sub { die if shift =~ /recurs/ }; + +TODO: +{ + local $TODO + = 'Loading Moose::Meta::Class without loading Moose.pm causes weird problems'; + + my $meta; + is( exception { + $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ 'Moose::Object', ], + ); + }, undef, 'Class is created successfully' ); +} + +done_testing; diff --git a/t/bugs/create_anon_role_pass.t b/t/bugs/create_anon_role_pass.t new file mode 100644 index 0000000..1e28d76 --- /dev/null +++ b/t/bugs/create_anon_role_pass.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose (); + +use lib 't/lib'; + +{ + package t::bugs::Bar; + use Moose; + + # empty class. + + no Moose; + __PACKAGE__->meta->make_immutable(); + + 1; +} + +my $meta; +use Data::Dumper; +isnt ( exception { + $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ 't::bugs::Bar', ], # any old class will work + roles => [ 'Role::BreakOnLoad', ], + ) +}, undef, 'Class dies when attempting composition'); + +my $except; +isnt ( $except = exception { + $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ 't::bugs::Bar', ], + roles => [ 'Role::BreakOnLoad', ], + ); +}, undef, 'Class continues to die when attempting composition'); + +done_testing; diff --git a/t/bugs/delete_sub_stash.t b/t/bugs/delete_sub_stash.t new file mode 100644 index 0000000..ce3f968 --- /dev/null +++ b/t/bugs/delete_sub_stash.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; + +use Moose (); + +{ + package Foo; + sub bar { 'BAR' } +} + +my $method = \&Foo::bar; + +{ + no strict 'refs'; + delete ${'::'}{'Foo::'}; +} + +my $meta = Moose::Meta::Class->create('Bar'); +$meta->add_method(bar => $method); +is(Bar->bar, 'BAR'); + +done_testing; diff --git a/t/bugs/handles_foreign_class_bug.t b/t/bugs/handles_foreign_class_bug.t new file mode 100644 index 0000000..4706d08 --- /dev/null +++ b/t/bugs/handles_foreign_class_bug.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + + sub new { + bless({}, 'Foo') + } + + sub a { 'Foo::a' } + + $INC{'Foo.pm'} = __FILE__; +} + +{ + package Bar; + use Moose; + + ::is( ::exception { + has 'baz' => ( + is => 'ro', + isa => 'Foo', + lazy => 1, + default => sub { Foo->new() }, + handles => qr/^a$/, + ); + }, undef, '... can create the attribute with delegations' ); + +} + +my $bar; +is( exception { + $bar = Bar->new; +}, undef, '... created the object ok' ); +isa_ok($bar, 'Bar'); + +is($bar->a, 'Foo::a', '... got the right delgated value'); + +my @w; +$SIG{__WARN__} = sub { push @w, "@_" }; +{ + package Baz; + use Moose; + + ::is( ::exception { + has 'bar' => ( + is => 'ro', + isa => 'Foo', + lazy => 1, + default => sub { Foo->new() }, + handles => qr/.*/, + ); + }, undef, '... can create the attribute with delegations' ); + +} + +is(@w, 0, "no warnings"); + + +my $baz; +is( exception { + $baz = Baz->new; +}, undef, '... created the object ok' ); +isa_ok($baz, 'Baz'); + +is($baz->a, 'Foo::a', '... got the right delgated value'); + + + + + +@w = (); + +{ + package Blart; + use Moose; + + ::is( ::exception { + has 'bar' => ( + is => 'ro', + isa => 'Foo', + lazy => 1, + default => sub { Foo->new() }, + handles => [qw(a new)], + ); + }, undef, '... can create the attribute with delegations' ); + +} + +{ + local $TODO = "warning not yet implemented"; + + is(@w, 1, "one warning"); + like($w[0], qr/not delegating.*new/i, "warned"); +} + + + +my $blart; +is( exception { + $blart = Blart->new; +}, undef, '... created the object ok' ); +isa_ok($blart, 'Blart'); + +is($blart->a, 'Foo::a', '... got the right delgated value'); + +done_testing; diff --git a/t/bugs/immutable_metaclass_does_role.t b/t/bugs/immutable_metaclass_does_role.t new file mode 100644 index 0000000..00cec0b --- /dev/null +++ b/t/bugs/immutable_metaclass_does_role.t @@ -0,0 +1,90 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +BEGIN { + package MyRole; + use Moose::Role; + + requires 'foo'; + + package MyMetaclass; + use Moose qw(extends with); + extends 'Moose::Meta::Class'; + with 'MyRole'; + + sub foo { 'i am foo' } +} + +{ + package MyClass; + use metaclass ('MyMetaclass'); + use Moose; +} + +my $mc = MyMetaclass->initialize('MyClass'); +isa_ok($mc, 'MyMetaclass'); + +ok($mc->meta->does_role('MyRole'), '... the metaclass does the role'); + +is(MyClass->meta, $mc, '... these metas are the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +my $a = MyClass->new; +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyClass->meta->make_immutable; +}, undef, '... make MyClass immutable okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyClass->meta->make_mutable; +}, undef, '... make MyClass mutable okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyMetaclass->meta->make_immutable; +}, undef, '... make MyMetaclass immutable okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyClass->meta->make_immutable; +}, undef, '... make MyClass immutable (again) okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +done_testing; diff --git a/t/bugs/immutable_n_default_x2.t b/t/bugs/immutable_n_default_x2.t new file mode 100644 index 0000000..2ba3e3b --- /dev/null +++ b/t/bugs/immutable_n_default_x2.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + our $foo_default_called = 0; + + has foo => ( + is => 'rw', + isa => 'Str', + default => sub { $foo_default_called++; 'foo' }, + ); + + our $bar_default_called = 0; + + has bar => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { $bar_default_called++; 'bar' }, + ); + + __PACKAGE__->meta->make_immutable; +} + +my $foo = Foo->new(); + +is($Foo::foo_default_called, 1, "foo default was only called once during constructor"); + +$foo->bar(); + +is($Foo::bar_default_called, 1, "bar default was only called once when lazy attribute is accessed"); + +done_testing; diff --git a/t/bugs/inheriting_from_roles.t b/t/bugs/inheriting_from_roles.t new file mode 100644 index 0000000..093864b --- /dev/null +++ b/t/bugs/inheriting_from_roles.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; +} +{ + package My::Class; + use Moose; + + ::like( ::exception { + extends 'My::Role'; + }, qr/You cannot inherit from a Moose Role \(My\:\:Role\)/, '... this croaks correctly' ); +} + +done_testing; diff --git a/t/bugs/inline_reader_bug.t b/t/bugs/inline_reader_bug.t new file mode 100644 index 0000000..ef14f71 --- /dev/null +++ b/t/bugs/inline_reader_bug.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This was a bug, but it is fixed now. This +test makes sure it does not creep back in. + +=cut + +{ + package Foo; + use Moose; + + ::is( ::exception { + has 'bar' => ( + is => 'ro', + isa => 'Int', + lazy => 1, + default => 10, + ); + }, undef, '... this didnt die' ); +} + +done_testing; diff --git a/t/bugs/instance_application_role_args.t b/t/bugs/instance_application_role_args.t new file mode 100644 index 0000000..120d12e --- /dev/null +++ b/t/bugs/instance_application_role_args.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More; + +{ + package Point; + use Moose; + + with qw/DoesNegated DoesTranspose/; + + has x => ( isa => 'Int', is => 'rw' ); + has y => ( isa => 'Int', is => 'rw' ); + + sub inspect { [$_[0]->x, $_[0]->y] } + + no Moose; +} + +{ + package DoesNegated; + use Moose::Role; + + sub negated { + my $self = shift; + $self->new( x => -$self->x, y => -$self->y ); + } + + no Moose::Role; +} + +{ + package DoesTranspose; + use Moose::Role; + + sub transpose { + my $self = shift; + $self->new( x => $self->y, y => $self->x ); + } + + no Moose::Role; +} + +my $p = Point->new( x => 4, y => 3 ); + +DoesTranspose->meta->apply( $p, -alias => { transpose => 'negated' } ); + +is_deeply($p->negated->inspect, [3, 4]); +is_deeply($p->transpose->inspect, [3, 4]); + +done_testing; diff --git a/t/bugs/lazybuild_required_undef.t b/t/bugs/lazybuild_required_undef.t new file mode 100644 index 0000000..9870587 --- /dev/null +++ b/t/bugs/lazybuild_required_undef.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +package Foo; +use Moose; + +## Problem: +## lazy_build sets required => 1 +## required does not permit setting to undef + +## Possible solutions: +#### remove required => 1 +#### check the attr to see if it accepts Undef (Maybe[], | Undef) +#### or, make required accept undef and use a predicate test + + +has 'foo' => ( isa => 'Int | Undef', is => 'rw', lazy_build => 1 ); +has 'bar' => ( isa => 'Int | Undef', is => 'rw' ); + +sub _build_foo { undef } + +package main; +use Test::More; + +ok ( !defined(Foo->new->bar), 'NonLazyBuild: Undef default' ); +ok ( !defined(Foo->new->bar(undef)), 'NonLazyBuild: Undef explicit' ); + +ok ( !defined(Foo->new->foo), 'LazyBuild: Undef default/lazy_build' ); + +## This test fails at the time of creation. +ok ( !defined(Foo->new->foo(undef)), 'LazyBuild: Undef explicit' ); + +done_testing; diff --git a/t/bugs/mark_as_methods_overloading_breakage.t b/t/bugs/mark_as_methods_overloading_breakage.t new file mode 100644 index 0000000..c9e0097 --- /dev/null +++ b/t/bugs/mark_as_methods_overloading_breakage.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Requires { + 'MooseX::MarkAsMethods' => 0, +}; + +{ + package Role2; + use Moose::Role; + use MooseX::MarkAsMethods; + use overload q{""} => '_stringify'; + sub _stringify {ref $_[0]} +} + +{ + package Class2; + use Moose; + with 'Role2'; +} + +ok(! exception { + my $class2 = Class2->new; + is( + "$class2", + 'Class2', + 'Class2 got stringification overloading from Role2' + ); +}, 'No error creating a Class2 object'); + +done_testing; diff --git a/t/bugs/moose_exporter_false_circular_reference_rt_63818.t b/t/bugs/moose_exporter_false_circular_reference_rt_63818.t new file mode 100644 index 0000000..dd41ce2 --- /dev/null +++ b/t/bugs/moose_exporter_false_circular_reference_rt_63818.t @@ -0,0 +1,154 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# OKSet1 +{ + + package TESTING::MooseExporter::Rt63818::OKSet1::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); +} + +# OKSet2 +{ + + package TESTING::MooseExporter::Rt63818::OKSet2::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet2::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); +} + +# OKSet3 +{ + + package TESTING::MooseExporter::Rt63818::OKSet3::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet3::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet3::ModuleA', + ] + ); +} + +# OKSet4 +{ + + package TESTING::MooseExporter::Rt63818::OKSet4::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet4::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet4::ModuleA', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet4::ModuleC; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet4::ModuleA', + 'TESTING::MooseExporter::Rt63818::OKSet4::ModuleB', + ] + ); +} + +# OKSet5 +{ + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleA', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleC; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleA', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleB', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleD; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleA', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleC', + ] + ); +} + +# NotOKSet1 +{ + + package TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA; + use Moose (); + ::like( + ::exception { Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA', + ] + ) + }, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA and TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA/, + 'a single-hop circular reference in also dies with an error' + ); +} + +# Alas, I've not figured out how to craft a test which shows that we get the +# same error for multi-hop circularity... instead I get tests that die because +# one of the circularly-referenced things was not loaded. + +done_testing; diff --git a/t/bugs/moose_octal_defaults.t b/t/bugs/moose_octal_defaults.t new file mode 100644 index 0000000..42a0fb5 --- /dev/null +++ b/t/bugs/moose_octal_defaults.t @@ -0,0 +1,121 @@ +use strict; +use warnings; + +use Test::More; + +{ + my $package = qq{ +package Test::Moose::Go::Boom; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => '019600', # this caused the original failure +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('quoted 019600 default works'); + my $obj = Test::Moose::Go::Boom->new; + ::is( $obj->id, '019600', 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom2; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => 017600, +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom2->new; + ::is( $obj->id, 8064, 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom3; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => 0xFF, +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom3->new; + ::is( $obj->id, 255, 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom4; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => '0xFF', +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom4->new; + ::is( $obj->id, '0xFF', 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom5; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => '0 but true', +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom5->new; + ::is( $obj->id, '0 but true', 'value is still the same' ); +} + +done_testing; diff --git a/t/bugs/native_trait_handles_bad_value.t b/t/bugs/native_trait_handles_bad_value.t new file mode 100644 index 0000000..34824aa --- /dev/null +++ b/t/bugs/native_trait_handles_bad_value.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + + package Bug; + use Moose; + + ::like( + ::exception{ has member => ( + is => 'ro', + isa => 'HashRef', + traits => ['Hash'], + handles => { + method => sub { } + }, + ); + }, + qr/\QAll values passed to handles must be strings or ARRAY references, not CODE/, + 'bad value in handles throws a useful error' + ); +} + +done_testing; diff --git a/t/bugs/overloading_edge_cases.t b/t/bugs/overloading_edge_cases.t new file mode 100644 index 0000000..af2abfc --- /dev/null +++ b/t/bugs/overloading_edge_cases.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Role::Overloads; + use Moose::Role; + use overload q{""} => 'as_string'; + requires 'as_string'; +} + +{ + package Class::Overloads; + use Moose; + with 'Role::Overloads'; + sub as_string { 'foo' } +} + +is( + Class::Overloads->new() . q{}, 'foo', + 'Class::Overloads overloads stringification with overloading defined in role and method defined in class' +); + +{ + package Parent::NoOverloads; + use Moose; + sub name { ref $_[0] } +} + +{ + package Child::Overloads; + use Moose; + use overload q{""} => 'name'; + extends 'Parent::NoOverloads'; +} + +is( + Child::Overloads->new() . q{}, 'Child::Overloads', + 'Child::Overloads overloads stringification with method inherited from parent' +); + +done_testing; diff --git a/t/bugs/reader_precedence_bug.t b/t/bugs/reader_precedence_bug.t new file mode 100644 index 0000000..e223a14 --- /dev/null +++ b/t/bugs/reader_precedence_bug.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + has 'foo' => ( is => 'ro', reader => 'get_foo' ); +} + +{ + my $foo = Foo->new(foo => 10); + my $reader = $foo->meta->get_attribute('foo')->reader; + is($reader, 'get_foo', + 'reader => "get_foo" has correct presedence'); + can_ok($foo, 'get_foo'); + is($foo->$reader, 10, "Reader works as expected"); +} + +done_testing; diff --git a/t/bugs/role_caller.t b/t/bugs/role_caller.t new file mode 100644 index 0000000..6fdf5a1 --- /dev/null +++ b/t/bugs/role_caller.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +package MyRole; + +use Moose::Role; + +sub foo { return (caller(0))[3] } + +no Moose::Role; + +package MyClass1; use Moose; with 'MyRole'; no Moose; +package MyClass2; use Moose; with 'MyRole'; no Moose; + +package main; + +use Test::More; + +{ + local $TODO = 'Role composition does not clone methods yet'; + is(MyClass1->foo, 'MyClass1::foo', + 'method from role has correct name in caller()'); + is(MyClass2->foo, 'MyClass2::foo', + 'method from role has correct name in caller()'); +} + +isnt(MyClass1->foo, "MyClass2::foo", "role method is not confused with other class" ); +isnt(MyClass2->foo, "MyClass1::foo", "role method is not confused with other class" ); + +done_testing; diff --git a/t/bugs/subclass_use_base_bug.t b/t/bugs/subclass_use_base_bug.t new file mode 100644 index 0000000..9a4521c --- /dev/null +++ b/t/bugs/subclass_use_base_bug.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This just makes sure that the Bar gets +a metaclass initialized for it correctly. + +=cut + +{ + package Foo; + use Moose; + + package Bar; + use strict; + use warnings; + + use parent -norequire => 'Foo'; +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +done_testing; diff --git a/t/bugs/subtype_conflict_bug.t b/t/bugs/subtype_conflict_bug.t new file mode 100644 index 0000000..93125cd --- /dev/null +++ b/t/bugs/subtype_conflict_bug.t @@ -0,0 +1,11 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; + +use_ok('MyMooseA'); +use_ok('MyMooseB'); + +done_testing; diff --git a/t/bugs/subtype_quote_bug.t b/t/bugs/subtype_quote_bug.t new file mode 100644 index 0000000..a507759 --- /dev/null +++ b/t/bugs/subtype_quote_bug.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This is a test for a bug found by Purge on #moose: +The code: + + subtype Stuff + => as Object + => where { ... } + +will break if the Object:: namespace exists. So the +solution is to quote 'Object', like so: + + subtype Stuff + => as 'Object' + => where { ... } + +Moose 0.03 did this, now it doesn't, so all should +be well from now on. + +=cut + +{ package Object::Test; } + +{ + package Foo; + ::use_ok('Moose'); +} + +done_testing; diff --git a/t/bugs/super_recursion.t b/t/bugs/super_recursion.t new file mode 100644 index 0000000..b6d920f --- /dev/null +++ b/t/bugs/super_recursion.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; + +{ + package First; + use Moose; + + sub foo { + ::BAIL_OUT('First::foo called twice') if $main::seen{'First::foo'}++; + return '1'; + } + + sub bar { + ::BAIL_OUT('First::bar called twice') if $main::seen{'First::bar'}++; + return '1'; + } + + sub baz { + ::BAIL_OUT('First::baz called twice') if $main::seen{'First::baz'}++; + return '1'; + } +} + +{ + package Second; + use Moose; + extends qw(First); + + sub foo { + ::BAIL_OUT('Second::foo called twice') if $main::seen{'Second::foo'}++; + return '2' . super(); + } + + sub bar { + ::BAIL_OUT('Second::bar called twice') if $main::seen{'Second::bar'}++; + return '2' . ( super() || '' ); + } + + override baz => sub { + ::BAIL_OUT('Second::baz called twice') if $main::seen{'Second::baz'}++; + return '2' . super(); + }; +} + +{ + package Third; + use Moose; + extends qw(Second); + + sub foo { return '3' . ( super() || '' ) } + + override bar => sub { + ::BAIL_OUT('Third::bar called twice') if $main::seen{'Third::bar'}++; + return '3' . super(); + }; + + override baz => sub { + ::BAIL_OUT('Third::baz called twice') if $main::seen{'Third::baz'}++; + return '3' . super(); + }; +} + +is( Third->new->foo, '3' ); +is( Third->new->bar, '32' ); +is( Third->new->baz, '321' ); + +done_testing; diff --git a/t/bugs/traits_with_exporter.t b/t/bugs/traits_with_exporter.t new file mode 100644 index 0000000..8f4fe92 --- /dev/null +++ b/t/bugs/traits_with_exporter.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use lib 't/lib'; + +BEGIN { + package MyExporterRole; + + use Moose (); + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => 'Moose', + ); + + sub init_meta { + my ($class,%args) = @_; + + my $meta = Moose->init_meta( %args ); + + Moose::Util::MetaRole::apply_metaroles( + for => $meta, + class_metaroles => { + class => ['MyMetaRole'], + }, + ); + + return $meta; + } + + $INC{'MyExporterRole.pm'} = __FILE__; +} + +{ + package MyMetaRole; + use Moose::Role; + + sub some_meta_class_method { + return "HEY" + } +} + +{ + package MyTrait; + use Moose::Role; + + sub some_meta_class_method_defined_by_trait { + return "HO" + } + + { + package Moose::Meta::Class::Custom::Trait::MyClassTrait; + use strict; + use warnings; + sub register_implementation { return 'MyTrait' } + } +} + +{ + package MyClass; + use MyExporterRole -traits => 'MyClassTrait'; +} + + + +my $my_class = MyClass->new; + +isa_ok($my_class,'MyClass'); + +my $meta = $my_class->meta(); +# Check if MyMetaRole has been applied +ok($meta->can('some_meta_class_method'),'Meta class has some_meta_class_method'); +# Check if MyTrait has been applied +ok($meta->can('some_meta_class_method_defined_by_trait'),'Meta class has some_meta_class_method_defined_by_trait'); + +done_testing; diff --git a/t/bugs/type_constraint_messages.t b/t/bugs/type_constraint_messages.t new file mode 100644 index 0000000..5bb076b --- /dev/null +++ b/t/bugs/type_constraint_messages.t @@ -0,0 +1,65 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +# RT #37569 + +{ + package MyObject; + use Moose; + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'MyArrayRef' + => as 'ArrayRef' + => where { defined $_->[0] } + => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy + ; + + subtype 'MyObjectType' + => as 'Object' + => where { $_->isa('MyObject') } + => message { + if ( $_->isa('SomeObject') ) { + return 'More detailed error message'; + } + elsif ( blessed $_ ) { + return 'Well it is an object'; + } + else { + return 'Doh!'; + } + } + ; + + type 'NewType' + => where { $_->isa('MyObject') } + => message { blessed $_ ? 'blessed' : 'scalar' } + ; + + has 'obj' => ( is => 'rw', isa => 'MyObjectType' ); + has 'ar' => ( is => 'rw', isa => 'MyArrayRef' ); + has 'nt' => ( is => 'rw', isa => 'NewType' ); +} + +my $foo = Foo->new; +my $obj = MyObject->new; + +like( exception { + $foo->ar( [] ); +}, qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/, '... got the right error message' ); + +like( exception { + $foo->obj($foo); # Doh! +}, qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/, '... got the right error message' ); + +like( exception { + $foo->nt($foo); # scalar +}, qr/Attribute \(nt\) does not pass the type constraint because: blessed/, '... got the right error message' ); + +done_testing; diff --git a/t/cmop/ArrayBasedStorage_test.t b/t/cmop/ArrayBasedStorage_test.t new file mode 100644 index 0000000..a654879 --- /dev/null +++ b/t/cmop/ArrayBasedStorage_test.t @@ -0,0 +1,203 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util 'reftype'; +use Class::MOP; + +use lib 't/cmop/lib'; +use ArrayBasedStorage; + +{ + package Foo; + + use strict; + use warnings; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + clearer => 'clear_foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + + use parent -norequire => 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(reftype($foo), 'ARRAY', '... Foo is made with ARRAY'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'clear_foo'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->clear_foo; + +ok(!$foo->has_foo, '... Foo::foo is not defined anymore'); +is($foo->foo(), undef, '... Foo::foo is not defined anymore'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is(reftype($foo2), 'ARRAY', '... Foo is made with ARRAY'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is(reftype($bar), 'ARRAY', '... Bar is made with ARRAY'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +is(reftype($baz), 'ARRAY', '... Bar::Baz is made with ARRAY'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +Foo->meta->add_attribute( forgotten => is => "rw" ); + +my $new_baz = Bar::Baz->new; + +cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" ); + +done_testing; diff --git a/t/cmop/AttributesWithHistory_test.t b/t/cmop/AttributesWithHistory_test.t new file mode 100644 index 0000000..3b28a12 --- /dev/null +++ b/t/cmop/AttributesWithHistory_test.t @@ -0,0 +1,118 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; +use AttributesWithHistory; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'get_foo_history'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'get_bar_history'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is($foo->foo, undef, '... foo is not yet defined'); +is_deeply( + [ $foo->get_foo_history() ], + [ ], + '... got correct empty history for foo'); + +is($foo2->foo, undef, '... foo2 is not yet defined'); +is_deeply( + [ $foo2->get_foo_history() ], + [ ], + '... got correct empty history for foo2'); + +$foo->foo(42); +is($foo->foo, 42, '... foo == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... got correct history for foo'); + +is($foo2->foo, undef, '... foo2 is still not yet defined'); +is_deeply( + [ $foo2->get_foo_history() ], + [ ], + '... still got correct empty history for foo2'); + +$foo2->foo(100); +is($foo->foo, 42, '... foo is still == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... still got correct history for foo'); + +is($foo2->foo, 100, '... foo2 == 100'); +is_deeply( + [ $foo2->get_foo_history() ], + [ 100 ], + '... got correct empty history for foo2'); + +$foo->foo(43); +$foo->foo(44); +$foo->foo(45); +$foo->foo(46); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... got correct history for foo'); + +is($foo->get_bar, undef, '... bar is not yet defined'); +is_deeply( + [ $foo->get_bar_history() ], + [ ], + '... got correct empty history for foo'); + + +$foo->set_bar("FOO"); +is($foo->get_bar, "FOO", '... bar == "FOO"'); +is_deeply( + [ $foo->get_bar_history() ], + [ "FOO" ], + '... got correct history for foo'); + +$foo->set_bar("BAR"); +$foo->set_bar("BAZ"); + +is_deeply( + [ $foo->get_bar_history() ], + [ qw/FOO BAR BAZ/ ], + '... got correct history for bar'); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... still have the correct history for foo'); + +done_testing; diff --git a/t/cmop/BinaryTree_test.t b/t/cmop/BinaryTree_test.t new file mode 100644 index 0000000..91831dc --- /dev/null +++ b/t/cmop/BinaryTree_test.t @@ -0,0 +1,329 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::Load qw( is_class_loaded load_class ); + +use lib 't/cmop/lib'; + +## ---------------------------------------------------------------------------- +## These are all tests which are derived from the Tree::Binary test suite +## ---------------------------------------------------------------------------- + +ok(!is_class_loaded('BinaryTree'), '... the binary tree class is not loaded'); + +is( exception { + load_class('BinaryTree'); +}, undef, '... loaded the BinaryTree class without dying' ); + +ok(is_class_loaded('BinaryTree'), '... the binary tree class is now loaded'); + +## ---------------------------------------------------------------------------- +## t/10_Tree_Binary_test.t + +can_ok("BinaryTree", 'new'); +can_ok("BinaryTree", 'setLeft'); +can_ok("BinaryTree", 'setRight'); + +my $btree = BinaryTree->new("/") + ->setLeft( + BinaryTree->new("+") + ->setLeft( + BinaryTree->new("2") + ) + ->setRight( + BinaryTree->new("2") + ) + ) + ->setRight( + BinaryTree->new("*") + ->setLeft( + BinaryTree->new("4") + ) + ->setRight( + BinaryTree->new("5") + ) + ); +isa_ok($btree, 'BinaryTree'); + +## informational methods + +can_ok($btree, 'isRoot'); +ok($btree->isRoot(), '... this is the root'); + +can_ok($btree, 'isLeaf'); +ok(!$btree->isLeaf(), '... this is not a leaf node'); +ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node'); + +can_ok($btree, 'hasLeft'); +ok($btree->hasLeft(), '... this has a left node'); + +can_ok($btree, 'hasRight'); +ok($btree->hasRight(), '... this has a right node'); + +## accessors + +can_ok($btree, 'getUID'); + +{ + my $UID = $btree->getUID(); + is(("$btree" =~ /\((.*?)\)$/)[0], $UID, '... our UID is derived from the stringified object'); +} + +can_ok($btree, 'getNodeValue'); +is($btree->getNodeValue(), '/', '... got what we expected'); + +{ + can_ok($btree, 'getLeft'); + my $left = $btree->getLeft(); + + isa_ok($left, 'BinaryTree'); + + is($left->getNodeValue(), '+', '... got what we expected'); + + can_ok($left, 'getParent'); + + my $parent = $left->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +{ + can_ok($btree, 'getRight'); + my $right = $btree->getRight(); + + isa_ok($right, 'BinaryTree'); + + is($right->getNodeValue(), '*', '... got what we expected'); + + can_ok($right, 'getParent'); + + my $parent = $right->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +## mutators + +can_ok($btree, 'setUID'); +$btree->setUID("Our UID for this tree"); + +is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected'); + +can_ok($btree, 'setNodeValue'); +$btree->setNodeValue('*'); + +is($btree->getNodeValue(), '*', '... got what we expected'); + + +{ + can_ok($btree, 'removeLeft'); + my $left = $btree->removeLeft(); + isa_ok($left, 'BinaryTree'); + + ok(!$btree->hasLeft(), '... we dont have a left node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setLeft($left); + + ok($btree->hasLeft(), '... we have our left node again'); + is($btree->getLeft(), $left, '... and it is what we told it to be'); +} + +{ + # remove left leaf + my $left_leaf = $btree->getLeft()->removeLeft(); + isa_ok($left_leaf, 'BinaryTree'); + + ok($left_leaf->isLeaf(), '... our left leaf is a leaf'); + + ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore'); + + $btree->getLeft()->setLeft($left_leaf); + + ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again'); + is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be'); +} + +{ + can_ok($btree, 'removeRight'); + my $right = $btree->removeRight(); + isa_ok($right, 'BinaryTree'); + + ok(!$btree->hasRight(), '... we dont have a right node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setRight($right); + + ok($btree->hasRight(), '... we have our right node again'); + is($btree->getRight(), $right, '... and it is what we told it to be') +} + +{ + # remove right leaf + my $right_leaf = $btree->getRight()->removeRight(); + isa_ok($right_leaf, 'BinaryTree'); + + ok($right_leaf->isLeaf(), '... our right leaf is a leaf'); + + ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore'); + + $btree->getRight()->setRight($right_leaf); + + ok($btree->getRight()->hasRight(), '... we have our right leaf node again'); + is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be'); +} + +# some of the recursive informational methods + +{ + + my $btree = BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ); + isa_ok($btree, 'BinaryTree'); + + can_ok($btree, 'size'); + cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree'); + + can_ok($btree, 'height'); + cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall'); + +} + +## ---------------------------------------------------------------------------- +## t/13_Tree_Binary_mirror_test.t + +sub inOrderTraverse { + my $tree = shift; + my @results; + my $_inOrderTraverse = sub { + my ($tree, $traversal_function) = @_; + $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft(); + push @results => $tree->getNodeValue(); + $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight(); + }; + $_inOrderTraverse->($tree, $_inOrderTraverse); + @results; +} + +# test it on a simple well balanaced tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(2) + ->setLeft( + BinaryTree->new(1) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ) + ->setRight( + BinaryTree->new(7) + ) + ); + isa_ok($btree, 'BinaryTree'); + + is_deeply( + [ inOrderTraverse($btree) ], + [ 1 .. 7 ], + '... check that our tree starts out correctly'); + + can_ok($btree, 'mirror'); + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(1 .. 7) ], + '... check that our tree ends up correctly'); +} + +# test is on a more chaotic tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(20) + ->setLeft( + BinaryTree->new(1) + ->setRight( + BinaryTree->new(10) + ->setLeft( + BinaryTree->new(5) + ) + ) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ->setRight( + BinaryTree->new(7) + ->setLeft( + BinaryTree->new(90) + ) + ->setRight( + BinaryTree->new(91) + ) + ) + ) + ); + isa_ok($btree, 'BinaryTree'); + + my @results = inOrderTraverse($btree); + + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(@results) ], + '... this should be the reverse of the original'); +} + +done_testing; diff --git a/t/cmop/C3MethodDispatchOrder_test.t b/t/cmop/C3MethodDispatchOrder_test.t new file mode 100644 index 0000000..65e0e83 --- /dev/null +++ b/t/cmop/C3MethodDispatchOrder_test.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Algorithm::C3'; # skip all if not installed + +use Class::MOP; + +use lib 't/cmop/lib'; +use C3MethodDispatchOrder; + +{ + package Diamond_A; + use metaclass 'C3MethodDispatchOrder'; + + sub hello { 'Diamond_A::hello' } + + package Diamond_B; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_A'); + + package Diamond_C; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_A'); + + sub hello { 'Diamond_C::hello' } + + package Diamond_D; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C'); +} + +is_deeply( + [ Diamond_D->meta->class_precedence_list ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order'); +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); + +done_testing; diff --git a/t/cmop/ClassEncapsulatedAttributes_test.t b/t/cmop/ClassEncapsulatedAttributes_test.t new file mode 100644 index 0000000..d5ee50b --- /dev/null +++ b/t/cmop/ClassEncapsulatedAttributes_test.t @@ -0,0 +1,106 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; +use ClassEncapsulatedAttributes; + +{ + package Foo; + + use metaclass 'ClassEncapsulatedAttributes'; + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in FOO' + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in FOO' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + our @ISA = ('Foo'); + + Bar->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in BAR' + )); + + Bar->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in BAR' + )); + + sub SUPER_foo { (shift)->SUPER::foo(@_) } + sub SUPER_has_foo { (shift)->SUPER::foo(@_) } + sub SUPER_get_bar { (shift)->SUPER::get_bar() } + sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) } + +} + +{ + my $foo = Foo->new(); + isa_ok($foo, 'Foo'); + + can_ok($foo, 'foo'); + can_ok($foo, 'has_foo'); + can_ok($foo, 'get_bar'); + can_ok($foo, 'set_bar'); + + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($foo->has_foo, '... Foo::has_foo == 1'); + ok($bar->has_foo, '... Bar::has_foo == 1'); + + is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo'); + is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo'); + + is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo'); + + $bar->SUPER_foo(undef); + + is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo'); + ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0'); + + ok($foo->has_foo, '... Foo::has_foo (is still) 1'); +} + +{ + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($bar->has_foo, '... Bar::has_foo == 1'); + ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1'); + + is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo'); + is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo'); +} + +done_testing; diff --git a/t/cmop/Class_C3_compatibility.t b/t/cmop/Class_C3_compatibility.t new file mode 100644 index 0000000..81ebabc --- /dev/null +++ b/t/cmop/Class_C3_compatibility.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests that Class::MOP works correctly +with Class::C3 and it's somewhat insane +approach to method resolution. + +=cut + +use Class::MOP; + +{ + package Diamond_A; + use mro 'c3'; + use metaclass; # everyone will just inherit this now :) + + sub hello { 'Diamond_A::hello' } +} +{ + package Diamond_B; + use mro 'c3'; + use parent -norequire => 'Diamond_A'; +} +{ + package Diamond_C; + use mro 'c3'; + use parent -norequire => 'Diamond_A'; + + sub hello { 'Diamond_C::hello' } +} +{ + package Diamond_D; + use mro 'c3'; + use parent -norequire => 'Diamond_B', 'Diamond_C'; +} + +# we have to manually initialize +# Class::C3 since we potentially +# skip this test if it is not present +Class::C3::initialize(); + +is_deeply( +# [ Class::C3::calculateMRO('Diamond_D') ], + [ Diamond_D->meta->class_precedence_list ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +ok(Diamond_A->meta->has_method('hello'), '... A has a method hello'); +ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello'); + +ok(Diamond_C->meta->has_method('hello'), '... C has a method hello'); +ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello'); + +SKIP: { + skip "C3 does not make aliases on 5.9.5+", 2 if $] > 5.009_004; + ok(defined &Diamond_B::hello, '... B does have an alias to the method hello'); + ok(defined &Diamond_D::hello, '... D does have an alias to the method hello'); +} + +done_testing; diff --git a/t/cmop/InsideOutClass_test.t b/t/cmop/InsideOutClass_test.t new file mode 100644 index 0000000..d54568c --- /dev/null +++ b/t/cmop/InsideOutClass_test.t @@ -0,0 +1,223 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util 'reftype'; + +use lib 't/cmop/lib'; +require InsideOutClass; + +{ + package Foo; + + use strict; + use warnings; + + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + use strict; + use warnings; + + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + + use strict; + use warnings; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + use strict; + use warnings; + + use parent -norequire => 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(reftype($foo), 'SCALAR', '... Foo is made with SCALAR'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is(reftype($foo2), 'SCALAR', '... Foo is made with SCALAR'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is(reftype($bar), 'SCALAR', '... Bar is made with SCALAR'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +is(reftype($baz), 'SCALAR', '... Bar::Baz is made with SCALAR'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +{ + no strict 'refs'; + + ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo'); + ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo'); + + is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo'); + is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar'); + + ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar'); + ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar'); + ok(*{'Bar::baz'}{HASH}, '... there is a baz package variable in Bar'); + + is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo'); + is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar'); + is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz'); + + ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz'); + + is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling'); + + ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz'); + ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz'); + ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz'); + ok(!*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz'); + + is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo'); + is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar'); + is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz'); + is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling'); +} + +done_testing; diff --git a/t/cmop/InstanceCountingClass_test.t b/t/cmop/InstanceCountingClass_test.t new file mode 100644 index 0000000..e7acc22 --- /dev/null +++ b/t/cmop/InstanceCountingClass_test.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use InstanceCountingClass; + +=pod + +This is a trivial and contrived example of how to +make a metaclass which will count all the instances +created. It is not meant to be anything more than +a simple demonstration of how to make a metaclass. + +=cut + +{ + package Foo; + + use metaclass 'InstanceCountingClass'; + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + + our @ISA = ('Foo'); +} + +is(Foo->meta->get_count(), 0, '... our Foo count is 0'); +is(Bar->meta->get_count(), 0, '... our Bar count is 0'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(Foo->meta->get_count(), 1, '... our Foo count is now 1'); +is(Bar->meta->get_count(), 0, '... our Bar count is still 0'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); + +is(Foo->meta->get_count(), 1, '... our Foo count is still 1'); +is(Bar->meta->get_count(), 1, '... our Bar count is now 1'); + +for (2 .. 10) { + Foo->new(); +} + +is(Foo->meta->get_count(), 10, '... our Foo count is now 10'); +is(Bar->meta->get_count(), 1, '... our Bar count is still 1'); + +done_testing; diff --git a/t/cmop/LazyClass_test.t b/t/cmop/LazyClass_test.t new file mode 100644 index 0000000..35db374 --- /dev/null +++ b/t/cmop/LazyClass_test.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use LazyClass; + +{ + package BinaryTree; + + use metaclass ( + 'attribute_metaclass' => 'LazyClass::Attribute', + 'instance_metaclass' => 'LazyClass::Instance', + ); + + BinaryTree->meta->add_attribute('node' => ( + accessor => 'node', + init_arg => 'node' + )); + + BinaryTree->meta->add_attribute('left' => ( + reader => 'left', + default => sub { BinaryTree->new() } + )); + + BinaryTree->meta->add_attribute('right' => ( + reader => 'right', + default => sub { BinaryTree->new() } + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } +} + +my $root = BinaryTree->new('node' => 0); +isa_ok($root, 'BinaryTree'); + +ok(exists($root->{'node'}), '... node attribute has been initialized yet'); +ok(!exists($root->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->{'right'}), '... right attribute has not been initialized yet'); + +isa_ok($root->left, 'BinaryTree'); +isa_ok($root->right, 'BinaryTree'); + +ok(exists($root->{'left'}), '... left attribute has now been initialized'); +ok(exists($root->{'right'}), '... right attribute has now been initialized'); + +ok(!exists($root->left->{'node'}), '... node attribute has not been initialized yet'); +ok(!exists($root->left->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->left->{'right'}), '... right attribute has not been initialized yet'); + +ok(!exists($root->right->{'node'}), '... node attribute has not been initialized yet'); +ok(!exists($root->right->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->right->{'right'}), '... right attribute has not been initialized yet'); + +is($root->left->node(), undef, '... the left node is uninitialized'); + +ok(exists($root->left->{'node'}), '... node attribute has now been initialized'); + +$root->left->node(1); +is($root->left->node(), 1, '... the left node == 1'); + +ok(!exists($root->left->{'left'}), '... left attribute still has not been initialized yet'); +ok(!exists($root->left->{'right'}), '... right attribute still has not been initialized yet'); + +is($root->right->node(), undef, '... the right node is uninitialized'); + +ok(exists($root->right->{'node'}), '... node attribute has now been initialized'); + +$root->right->node(2); +is($root->right->node(), 2, '... the right node == 1'); + +ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet'); +ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet'); + +done_testing; diff --git a/t/cmop/Perl6Attribute_test.t b/t/cmop/Perl6Attribute_test.t new file mode 100644 index 0000000..9b3d73f --- /dev/null +++ b/t/cmop/Perl6Attribute_test.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use Perl6Attribute; + +{ + package Foo; + + use metaclass; + + Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); + Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); + Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'bar'); +can_ok($foo, 'baz'); + +is($foo->foo, undef, '... Foo.foo == undef'); + +$foo->foo(42); +is($foo->foo, 42, '... Foo.foo == 42'); + +is_deeply($foo->bar, [], '... Foo.bar == []'); +is_deeply($foo->baz, {}, '... Foo.baz == {}'); + +done_testing; diff --git a/t/cmop/RT_27329_fix.t b/t/cmop/RT_27329_fix.t new file mode 100644 index 0000000..0c8ee6a --- /dev/null +++ b/t/cmop/RT_27329_fix.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +=pod + +This tests a bug sent via RT #27329 + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('foo' => ( + init_arg => 'foo', + reader => 'get_foo', + default => 'BAR', + )); + +} + +my $foo = Foo->meta->new_object; +isa_ok($foo, 'Foo'); + +is($foo->get_foo, 'BAR', '... got the right default value'); + +{ + my $clone = $foo->meta->clone_object($foo, foo => 'BAZ'); + isa_ok($clone, 'Foo'); + isnt($clone, $foo, '... and it is a clone'); + + is($clone->get_foo, 'BAZ', '... got the right cloned value'); +} + +{ + my $clone = $foo->meta->clone_object($foo, foo => undef); + isa_ok($clone, 'Foo'); + isnt($clone, $foo, '... and it is a clone'); + + ok(!defined($clone->get_foo), '... got the right cloned value'); +} + +done_testing; diff --git a/t/cmop/RT_39001_fix.t b/t/cmop/RT_39001_fix.t new file mode 100644 index 0000000..a3575e8 --- /dev/null +++ b/t/cmop/RT_39001_fix.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +=pod + +This tests a bug sent via RT #39001 + +=cut + +{ + package Foo; + use metaclass; +} + +like( exception { + Foo->meta->superclasses('Foo'); +}, qr/^Recursive inheritance detected/, "error occurs when extending oneself" ); + +{ + package Bar; + use metaclass; +} + +# reset @ISA, so that calling methods like ->isa won't die (->meta does this +# if DEBUG_NO_META is set) +@Foo::ISA = (); + +is( exception { + Foo->meta->superclasses('Bar'); +}, undef, "regular subclass" ); + +like( exception { + Bar->meta->superclasses('Foo'); +}, qr/^Recursive inheritance detected/, "error occurs when Bar extends Foo, when Foo is a Bar" ); + +done_testing; diff --git a/t/cmop/RT_41255.t b/t/cmop/RT_41255.t new file mode 100644 index 0000000..101d358 --- /dev/null +++ b/t/cmop/RT_41255.t @@ -0,0 +1,51 @@ +use strict; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package BaseClass; + sub m1 { 1 } + sub m2 { 2 } + sub m3 { 3 } + sub m4 { 4 } + sub m5 { 5 } + + package Derived; + use parent -norequire => 'BaseClass'; + + sub m1; + sub m2 (); + sub m3 :method; + sub m4; m4() if 0; + sub m5; our $m5;; +} + +my $meta = Class::MOP::Class->initialize('Derived'); +my %methods = map { $_ => $meta->find_method_by_name($_) } 'm1' .. 'm5'; + +while (my ($name, $meta_method) = each %methods) { + is $meta_method->fully_qualified_name, "Derived::${name}"; + like( exception { $meta_method->execute }, qr/Undefined subroutine .* called at/ ); +} + +{ + package Derived; + eval <<'EOC'; + + sub m1 { 'affe' } + sub m2 () { 'apan' } + sub m3 :method { 'tiger' } + sub m4 { 'birne' } + sub m5 { 'apfel' } + +EOC +} + +while (my ($name, $meta_method) = each %methods) { + is $meta_method->fully_qualified_name, "Derived::${name}"; + is( exception { $meta_method->execute }, undef ); +} + +done_testing; diff --git a/t/cmop/add_attribute_alternate.t b/t/cmop/add_attribute_alternate.t new file mode 100644 index 0000000..f7ecde1 --- /dev/null +++ b/t/cmop/add_attribute_alternate.t @@ -0,0 +1,109 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Point; + use metaclass; + + Point->meta->add_attribute('x' => ( + reader => 'x', + init_arg => 'x' + )); + + Point->meta->add_attribute('y' => ( + accessor => 'y', + init_arg => 'y' + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } + + sub clear { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + + package Point3D; + our @ISA = ('Point'); + + Point3D->meta->add_attribute('z' => ( + default => 123 + )); + + sub clear { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } +} + +isa_ok(Point->meta, 'Class::MOP::Class'); +isa_ok(Point3D->meta, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the y attribute was set properly with the accessor'); + +is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); + +isnt( exception { + $point->x(42); +}, undef, '... cannot write to a read-only accessor' ); +is($point->x, 2, '... the x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the y attribute was cleared correctly'); +is($point->x, 0, '... the x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); +is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the x attribute was not initialized'); + is($point3d->y, undef, '... the y attribute was not initialized'); + is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); + +} + +done_testing; diff --git a/t/cmop/add_method_debugmode.t b/t/cmop/add_method_debugmode.t new file mode 100644 index 0000000..152b990 --- /dev/null +++ b/t/cmop/add_method_debugmode.t @@ -0,0 +1,140 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Class::MOP::Mixin::HasMethods; + +# When the Perl debugger is enabled, %DB::sub tracks method information +# (line numbers and originating file). However, the reinitialize() +# functionality for classes and roles can sometimes clobber this information, +# causing to reference internal MOP files/lines instead. +# These tests check to make sure the the reinitialize() functionality +# preserves the correct debugging information when it (re)adds methods +# back into a class or role. + +BEGIN { + $^P = 831; # Enable debug mode +} + +# Empty debugger +sub DB::DB {} + +my ($foo_role_start, $foo_role_end, $foo_start_1, $foo_end_1, $foo_start_2, $foo_end_2); + +# Simple Moose Role +{ + package FooRole; + use Moose::Role; + + $foo_role_start = __LINE__ + 1; + sub foo_role { + return 'FooRole::foo_role'; + } + $foo_role_end = __LINE__ - 1; +} + +# Simple Moose package +{ + package Foo; + use Moose; + + with 'FooRole'; + + # Track the start/end line numbers of method foo(), for comparison later + $foo_start_1 = __LINE__ + 1; + sub foo { + return 'foo'; + } + $foo_end_1 = __LINE__ - 1; + + no Moose; +} + +# Extend our simple Moose package, with overriding method +{ + package Bar; + use Moose; + + extends 'Foo'; + + # Track the start/end line numbers of method foo(), for comparison later + $foo_start_2 = __LINE__ + 1; + sub foo { + return 'bar'; + } + $foo_end_2 = __LINE__ - 1; + + no Moose; +} + +# Check that Foo and Bar classes were set up correctly +my $bar_object = Bar->new(); +isa_ok(Foo->meta->get_method('foo'), 'Moose::Meta::Method'); +isa_ok(Bar->meta->get_method('foo'), 'Moose::Meta::Method'); +isa_ok(Foo->meta->get_method('foo_role'), 'Moose::Meta::Method'); +is($bar_object->foo_role(), 'FooRole::foo_role', 'Bar object has access to foo_role method'); + +# Run tests against Bar meta class... + +my $bar_meta = Bar->meta; +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (initial)"); + +# Run _restore_metamethods_from directly (part of the reinitialize() process) +$bar_meta->_restore_metamethods_from($bar_meta); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after _restore)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after _restore)"); + +# Call reinitialize explicitly, which triggers HasMethods::add_method +is( exception { + $bar_meta = $bar_meta->reinitialize('Bar'); +}, undef ); +isa_ok(Bar->meta->get_method('foo'), 'Moose::Meta::Method'); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after reinitialize)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after reinitialize)"); + +# Add a method to Bar; this triggers reinitialize as well +# Check that method line numbers are still listed as part of this file, and not a MOP file +$bar_meta->add_method('foo2' => sub { return 'new method foo2'; }); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after add_method)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after add_method)"); +like($DB::sub{"Bar::foo2"}, qr/(.*):(\d+)-(\d+)/, "Check for existence of Bar::foo2"); + +# Clobber Bar::foo by adding a method with the same name +$bar_meta->add_method( + 'foo' => $bar_meta->method_metaclass->wrap( + package_name => $bar_meta->name, + name => 'foo', + body => sub { return 'clobbered Bar::foo'; } + ) +); +unlike($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t/, "Check that source file for Bar::foo has changed"); + +# Run tests against FooRole meta role ... + +my $foorole_meta = FooRole->meta; +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (initial)"); + +# Call _restore_metamethods_from directly +$foorole_meta->_restore_metamethods_from($foorole_meta); +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (after _restore)"); + +# Call reinitialize +# Check that method line numbers are still listed as part of this file +is( exception { + $foorole_meta->reinitialize('FooRole'); +}, undef ); +isa_ok(FooRole->meta->get_method('foo_role'), 'Moose::Meta::Method'); +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (after reinitialize)"); + +# Clobber foo_role method +$foorole_meta->add_method( + 'foo_role' => $foorole_meta->method_metaclass->wrap( + package_name => $foorole_meta->name, + name => 'foo_role', + body => sub { return 'clobbered FooRole::foo_role'; } + ) +); +unlike($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t/, "Check that source file for FooRole::foo_role has changed"); + +done_testing; diff --git a/t/cmop/add_method_modifier.t b/t/cmop/add_method_modifier.t new file mode 100644 index 0000000..b2f4a6c --- /dev/null +++ b/t/cmop/add_method_modifier.t @@ -0,0 +1,135 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + + package BankAccount; + + use strict; + use warnings; + use metaclass; + + use Carp 'confess'; + + BankAccount->meta->add_attribute( + 'balance' => ( + accessor => 'balance', + init_arg => 'balance', + default => 0 + ) + ); + + sub new { (shift)->meta->new_object(@_) } + + sub deposit { + my ( $self, $amount ) = @_; + $self->balance( $self->balance + $amount ); + } + + sub withdraw { + my ( $self, $amount ) = @_; + my $current_balance = $self->balance(); + ( $current_balance >= $amount ) + || confess "Account overdrawn"; + $self->balance( $current_balance - $amount ); + } + + package CheckingAccount; + + use strict; + use warnings; + use metaclass; + + use parent -norequire => 'BankAccount'; + + CheckingAccount->meta->add_attribute( + 'overdraft_account' => ( + accessor => 'overdraft_account', + init_arg => 'overdraft', + ) + ); + + CheckingAccount->meta->add_before_method_modifier( + 'withdraw' => sub { + my ( $self, $amount ) = @_; + my $overdraft_amount = $amount - $self->balance(); + if ( $overdraft_amount > 0 ) { + $self->overdraft_account->withdraw($overdraft_amount); + $self->deposit($overdraft_amount); + } + } + ); + + ::like( + ::exception{ CheckingAccount->meta->add_before_method_modifier( + 'does_not_exist' => sub { } + ); + }, + qr/\QThe method 'does_not_exist' was not found in the inheritance hierarchy for CheckingAccount/ + ); + + ::ok( CheckingAccount->meta->has_method('withdraw'), + '... checking account now has a withdraw method' ); + ::isa_ok( CheckingAccount->meta->get_method('withdraw'), + 'Class::MOP::Method::Wrapped' ); + ::isa_ok( BankAccount->meta->get_method('withdraw'), + 'Class::MOP::Method' ); + + CheckingAccount->meta->add_method( foo => sub { 'foo' } ); + CheckingAccount->meta->add_before_method_modifier( foo => sub { 'wrapped' } ); + ::isa_ok( CheckingAccount->meta->get_method('foo'), + 'Class::MOP::Method::Wrapped' ); +} + +my $savings_account = BankAccount->new( balance => 250 ); +isa_ok( $savings_account, 'BankAccount' ); + +is( $savings_account->balance, 250, '... got the right savings balance' ); +is( exception { + $savings_account->withdraw(50); +}, undef, '... withdrew from savings successfully' ); +is( $savings_account->balance, 200, + '... got the right savings balance after withdrawal' ); +isnt( exception { + $savings_account->withdraw(250); +}, undef, '... could not withdraw from savings successfully' ); + +$savings_account->deposit(150); +is( $savings_account->balance, 350, + '... got the right savings balance after deposit' ); + +my $checking_account = CheckingAccount->new( + balance => 100, + overdraft => $savings_account +); +isa_ok( $checking_account, 'CheckingAccount' ); +isa_ok( $checking_account, 'BankAccount' ); + +is( $checking_account->overdraft_account, $savings_account, + '... got the right overdraft account' ); + +is( $checking_account->balance, 100, '... got the right checkings balance' ); + +is( exception { + $checking_account->withdraw(50); +}, undef, '... withdrew from checking successfully' ); +is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); +is( $savings_account->balance, 350, + '... got the right savings balance after checking withdrawal (no overdraft)' +); + +is( exception { + $checking_account->withdraw(200); +}, undef, '... withdrew from checking successfully' ); +is( $checking_account->balance, 0, + '... got the right checkings balance after withdrawal' ); +is( $savings_account->balance, 200, + '... got the right savings balance after overdraft withdrawal' ); + +done_testing; diff --git a/t/cmop/advanced_methods.t b/t/cmop/advanced_methods.t new file mode 100644 index 0000000..6cd0d02 --- /dev/null +++ b/t/cmop/advanced_methods.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; +use Class::MOP::Class; + +=pod + +The following class hierarhcy is very contrived +and totally horrid (it won't work under C3 even), +but it tests a number of aspect of this module. + +A more real-world example would be a nice addition :) + +=cut + +{ + package Foo; + + sub BUILD { 'Foo::BUILD' } + sub foo { 'Foo::foo' } + + package Bar; + our @ISA = ('Foo'); + + sub BUILD { 'Bar::BUILD' } + sub bar { 'Bar::bar' } + + package Baz; + our @ISA = ('Bar'); + + sub baz { 'Baz::baz' } + sub foo { 'Baz::foo' } + + package Foo::Bar; + our @ISA = ('Foo', 'Bar'); + + sub BUILD { 'Foo::Bar::BUILD' } + sub foobar { 'Foo::Bar::foobar' } + + package Foo::Bar::Baz; + our @ISA = ('Foo', 'Bar', 'Baz'); + + sub BUILD { 'Foo::Bar::Baz::BUILD' } + sub bar { 'Foo::Bar::Baz::bar' } + sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' } +} + +ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')), + '... Foo::BUILD has not next method'); + +is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Bar::BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + '... Baz->BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Foo::Bar->BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Foo::Bar::Baz->BUILD does have a next method'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Foo')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Foo')->get_method('BUILD') , + Class::MOP::Class->initialize('Foo')->get_method('foo'), + ], + '... got the right list of applicable methods for Foo'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Bar')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Foo')->get_method('foo'), + ], + '... got the right list of applicable methods for Bar'); + + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Baz')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Baz')->get_method('baz'), + Class::MOP::Class->initialize('Baz')->get_method('foo'), + ], + '... got the right list of applicable methods for Baz'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Foo::Bar')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Foo')->get_method('foo'), + Class::MOP::Class->initialize('Foo::Bar')->get_method('foobar'), + ], + '... got the right list of applicable methods for Foo::Bar'); + +## find_all_methods_by_name + +is_deeply( + [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ], + [ + { + name => 'BUILD', + class => 'Foo::Bar', + code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Foo', + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Bar', + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') + } + ], + '... got the right list of BUILD methods for Foo::Bar'); + +is_deeply( + [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ], + [ + { + name => 'BUILD', + class => 'Foo::Bar::Baz', + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Foo', + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Bar', + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') + }, + ], + '... got the right list of BUILD methods for Foo::Bar::Baz'); + +done_testing; diff --git a/t/cmop/anon_class.t b/t/cmop/anon_class.t new file mode 100644 index 0000000..19681e1 --- /dev/null +++ b/t/cmop/anon_class.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub bar { 'Foo::bar' } +} + +my $anon_class_id; +{ + my $instance; + { + my $anon_class = Class::MOP::Class->create_anon_class(); + isa_ok($anon_class, 'Class::MOP::Class'); + + ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/); + + ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists'); + like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name'); + + is_deeply( + [$anon_class->superclasses], + [], + '... got an empty superclass list'); + is( exception { + $anon_class->superclasses('Foo'); + }, undef, '... can add a superclass to anon class' ); + is_deeply( + [$anon_class->superclasses], + [ 'Foo' ], + '... got the right superclass list'); + + ok(!$anon_class->has_method('foo'), '... no foo method'); + is( exception { + $anon_class->add_method('foo' => sub { "__ANON__::foo" }); + }, undef, '... added a method to my anon-class' ); + ok($anon_class->has_method('foo'), '... we have a foo method now'); + + $instance = $anon_class->new_object(); + isa_ok($instance, $anon_class->name); + isa_ok($instance, 'Foo'); + + is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method'); + is($instance->bar, 'Foo::bar', '... got the right return value of our bar method'); + } + + ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists'); +} + +local $TODO = "anon class doesn't get GCed under Devel::Cover" if $INC{'Devel/Cover.pm'}; + +ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists'); + +# but it breaks down when we try to create another one ... + +my $instance_2 = bless {} => ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id); +isa_ok($instance_2, ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id)); +ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo'); +ok(!$instance_2->can('foo'), '... and it can no longer call the foo method'); + +done_testing; diff --git a/t/cmop/anon_class_create_init.t b/t/cmop/anon_class_create_init.t new file mode 100644 index 0000000..a35a1eb --- /dev/null +++ b/t/cmop/anon_class_create_init.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package MyMeta; + use parent 'Class::MOP::Class'; + sub initialize { + my $class = shift; + my ( $package, %options ) = @_; + ::cmp_ok( $options{foo}, 'eq', 'this', + 'option passed to initialize() on create_anon_class()' ); + return $class->SUPER::initialize( @_ ); + } + +} + +{ + my $anon = MyMeta->create_anon_class( foo => 'this' ); + isa_ok( $anon, 'MyMeta' ); +} + +my $instance; + +{ + my $meta = Class::MOP::Class->create_anon_class; + $instance = $meta->new_object; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away"); +} + +{ + my $meta = Class::MOP::Class->create_anon_class; + $meta->make_immutable; + $instance = $meta->name->new; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances (immutable)"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away (immutable)"); +} + +{ + $instance = Class::MOP::Class->create('Foo')->new_object; + my $meta = Class::MOP::Class->create_anon_class(superclasses => ['Foo']); + $meta->rebless_instance($instance); +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away"); +} + +{ + { + my $meta = Class::MOP::Class->create_anon_class; + { + my $submeta = Class::MOP::Class->create_anon_class( + superclasses => [$meta->name] + ); + $instance = $submeta->new_object; + } + { + my $submeta = Class::MOP::class_of($instance); + Scalar::Util::weaken($submeta); + ok($submeta, "anon class is kept alive by existing instances"); + + $meta->rebless_instance_back($instance); + ok(!$submeta, "reblessing away loses the metaclass"); + } + } + + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); +} + +{ + my $submeta = Class::MOP::Class->create_anon_class( + superclasses => [Class::MOP::Class->create_anon_class->name], + ); + my @superclasses = $submeta->superclasses; + ok(Class::MOP::class_of($superclasses[0]), + "superclasses are kept alive by their subclasses"); +} + +{ + my $meta_name; + { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => ['Class::MOP::Class'], + ); + $meta_name = $meta->name; + ok(Class::MOP::metaclass_is_weak($meta_name), + "default is for anon metaclasses to be weakened"); + } + ok(!Class::MOP::class_of($meta_name), + "and weak metaclasses go away when all refs do"); + { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => ['Class::MOP::Class'], + weaken => 0, + ); + $meta_name = $meta->name; + ok(!Class::MOP::metaclass_is_weak($meta_name), + "anon classes can be told not to weaken"); + } + ok(Class::MOP::class_of($meta_name), "metaclass still exists"); + { + my $bar_meta; + is( exception { + $bar_meta = $meta_name->initialize('Bar'); + }, undef, "we can use the name on its own" ); + isa_ok($bar_meta, $meta_name); + } +} + +{ + my $meta = Class::MOP::Class->create( + 'Baz', + weaken => 1, + ); + $instance = $meta->new_object; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "weak class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "weak class is collected once instances go away"); +} + +done_testing; diff --git a/t/cmop/anon_class_keep_alive.t b/t/cmop/anon_class_keep_alive.t new file mode 100644 index 0000000..ace95d8 --- /dev/null +++ b/t/cmop/anon_class_keep_alive.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my $anon_class_name; +my $anon_meta_name; +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub make_anon_instance{ + my $self = shift; + my $class = ref $self || $self; + + my $anon_class = Class::MOP::Class->create_anon_class(superclasses => [$class]); + $anon_class_name = $anon_class->name; + $anon_meta_name = Scalar::Util::blessed($anon_class); + $anon_class->add_attribute( $_, reader => $_ ) for qw/bar baz/; + + my $obj = $anon_class->new_object(bar => 'a', baz => 'b'); + return $obj; + } + + sub foo{ 'foo' } + + 1; +} + +my $instance = Foo->make_anon_instance; + +isa_ok($instance, $anon_class_name); +isa_ok($instance->meta, $anon_meta_name); +isa_ok($instance, 'Foo', '... Anonymous instance isa Foo'); + +ok($instance->can('foo'), '... Anonymous instance can foo'); +ok($instance->meta->find_method_by_name('foo'), '... Anonymous instance has method foo'); + +ok($instance->meta->has_attribute('bar'), '... Anonymous instance still has attribute bar'); +ok($instance->meta->has_attribute('baz'), '... Anonymous instance still has attribute baz'); +is($instance->bar, 'a', '... Anonymous instance still has correct bar value'); +is($instance->baz, 'b', '... Anonymous instance still has correct baz value'); + +is_deeply([$instance->meta->class_precedence_list], + [$anon_class_name, 'Foo'], + '... Anonymous instance has class precedence list', + ); + +done_testing; diff --git a/t/cmop/anon_class_leak.t b/t/cmop/anon_class_leak.t new file mode 100644 index 0000000..0a292fc --- /dev/null +++ b/t/cmop/anon_class_leak.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::LeakTrace'; # skip all if not installed + +BEGIN { + plan skip_all => 'Leak tests fail under Devel::Cover' if $INC{'Devel/Cover.pm'}; +} + +use Class::MOP; + +# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV. +my $expected = ( $] == 5.010_000 ? 1 : 0 ); + +leaks_cmp_ok { + Class::MOP::Class->create_anon_class(); +} +'<=', $expected, 'create_anon_class()'; + +leaks_cmp_ok { + Class::MOP::Class->create_anon_class( superclasses => [qw(Exporter)] ); +} +'<=', $expected, 'create_anon_class(superclass => [...])'; + +done_testing; diff --git a/t/cmop/anon_class_removal.t b/t/cmop/anon_class_removal.t new file mode 100644 index 0000000..9d0313a --- /dev/null +++ b/t/cmop/anon_class_removal.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; + +{ + my $class; + { + my $meta = Class::MOP::Class->create_anon_class( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $class = $meta->name; + can_ok($class, 'foo'); + is($class->foo, 'FOO'); + } + ok(!$class->can('foo')); +} + +{ + my $class; + { + my $meta = Class::MOP::Class->create_anon_class( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $class = $meta->name; + can_ok($class, 'foo'); + is($class->foo, 'FOO'); + Class::MOP::remove_metaclass_by_name($class); + } + ok(!$class->can('foo')); +} + +done_testing; diff --git a/t/cmop/anon_packages.t b/t/cmop/anon_packages.t new file mode 100644 index 0000000..3e5df88 --- /dev/null +++ b/t/cmop/anon_packages.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + my $name; + { + my $anon = Class::MOP::Package->create_anon; + $name = $anon->name; + $anon->add_package_symbol('&foo' => sub {}); + can_ok($name, 'foo'); + ok($anon->is_anon, "is anon"); + } + + ok(!$name->can('foo'), "!$name->can('foo')"); +} + +{ + my $name; + { + my $anon = Class::MOP::Package->create_anon(weaken => 0); + $name = $anon->name; + $anon->add_package_symbol('&foo' => sub {}); + can_ok($name, 'foo'); + ok($anon->is_anon, "is anon"); + } + + can_ok($name, 'foo'); +} + +{ + like(exception { Class::MOP::Package->create_anon(cache => 1) }, + qr/^Packages are not cacheable/, + "can't cache anon packages"); +} + +done_testing; diff --git a/t/cmop/attribute.t b/t/cmop/attribute.t new file mode 100644 index 0000000..f23a434 --- /dev/null +++ b/t/cmop/attribute.t @@ -0,0 +1,248 @@ +use strict; +use warnings; + +use Scalar::Util 'reftype', 'blessed'; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Attribute; +use Class::MOP::Method; + + +isnt( exception { Class::MOP::Attribute->name }, undef, q{... can't call name() as a class method} ); + + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '$foo', '... $attr init_arg is the name'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + ok(!$attr->has_default, '... $attr does not have an default'); + ok(!$attr->has_builder, '... $attr does not have a builder'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is a plain old sub'); + ok(!blessed($writer), '... it is a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $class = Class::MOP::Class->initialize('Foo'); + isa_ok($class, 'Class::MOP::Class'); + + is( exception { + $attr->attach_to_class($class); + }, undef, '... attached a class successfully' ); + + is($attr->associated_class, $class, '... the class was associated correctly'); + + ok(!$attr->get_read_method, '... $attr does not have an read method'); + ok(!$attr->get_write_method, '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(blessed($reader), '... it is a plain old sub'); + ok(blessed($writer), '... it is a plain old sub'); + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, $class, '... the associated classes are the same though'); + is($attr_clone->associated_class, $class, '... the associated classes are the same though'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + ok(!$attr->has_builder, '... $attr does not have a builder'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + + ok(!$attr->get_read_method, '... $attr does not have an read method'); + ok(!$attr->get_write_method, '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is a plain old sub'); + ok(!blessed($writer), '... it is a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, undef, '... the associated class is actually undef'); + is($attr_clone->associated_class, undef, '... the associated class is actually undef'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_accessor, '... $attr does have an accessor'); + is($attr->accessor, 'foo', '... $attr->accessor == foo'); + + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + + is($attr->get_read_method, 'foo', '... $attr does not have an read method'); + is($attr->get_write_method, 'foo', '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is not a plain old sub'); + ok(!blessed($writer), '... it is not a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + reader => 'get_foo', + writer => 'set_foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_reader, '... $attr does have an reader'); + is($attr->reader, 'get_foo', '... $attr->reader == get_foo'); + ok($attr->has_writer, '... $attr does have an writer'); + is($attr->writer, 'set_foo', '... $attr->writer == set_foo'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + + is($attr->get_read_method, 'get_foo', '... $attr does not have an read method'); + is($attr->get_write_method, 'set_foo', '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is not a plain old sub'); + ok(!blessed($writer), '... it is not a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + my $attr_clone = $attr->clone('name' => '$bar'); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + isnt($attr->name, $attr_clone->name, '... we changes the name parameter'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + is($attr_clone->name, '$bar', '... $attr_clone->name == $bar'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', (builder => 'foo_builder')); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_default, '... $attr does not have a default'); + ok($attr->has_builder, '... $attr does have a builder'); + is($attr->builder, 'foo_builder', '... $attr->builder == foo_builder'); + +} + +{ + for my $value ({}, bless({}, 'Foo')) { + like( exception { + Class::MOP::Attribute->new('$foo', default => $value); + }, qr/References are not allowed as default values/ ); + } +} + +{ + my $attr; + is( exception { + my $meth = Class::MOP::Method->wrap(sub {shift}, name => 'foo', package_name => 'bar'); + $attr = Class::MOP::Attribute->new('$foo', default => $meth); + }, undef, 'Class::MOP::Methods accepted as default' ); + + is($attr->default(42), 42, 'passthrough for default on attribute'); +} + +done_testing; diff --git a/t/cmop/attribute_duplication.t b/t/cmop/attribute_duplication.t new file mode 100644 index 0000000..4c4073f --- /dev/null +++ b/t/cmop/attribute_duplication.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Scalar::Util; + +use Test::More; + +use Class::MOP; + +=pod + +This tests that when an attribute of the same name +is added to a class, that it will remove the old +one first. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + ::can_ok('Foo', 'get_bar'); + ::can_ok('Foo', 'set_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); + + my $bar_attr = Foo->meta->get_attribute('bar'); + + ::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); + ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); + ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + + Foo->meta->add_attribute('bar' => + reader => 'assign_bar' + ); + + ::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method'); + ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method'); + ::can_ok('Foo', 'assign_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar'); + + my $bar_attr2 = Foo->meta->get_attribute('bar'); + + ::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute'); + ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta'); + + ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta'); + + ::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar'); + ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar'); + ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar'); +} + +done_testing; diff --git a/t/cmop/attribute_errors_and_edge_cases.t b/t/cmop/attribute_errors_and_edge_cases.t new file mode 100644 index 0000000..e4a87d6 --- /dev/null +++ b/t/cmop/attribute_errors_and_edge_cases.t @@ -0,0 +1,232 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Attribute; + +# most values are static + +{ + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => qr/hello (.*)/ + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => [] + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => {} + )); + }, undef, '... no refs for defaults' ); + + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => \(my $var) + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => bless {} => 'Foo' + )); + }, undef, '... no refs for defaults' ); + +} + +{ + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => qr/hello (.*)/ + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => [] + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => {} + )); + }, undef, '... no refs for builders' ); + + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => \(my $var) + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => bless {} => 'Foo' + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => 'Foo', default => 'Foo' + )); + }, undef, '... no default AND builder' ); + + my $undef_attr; + is( exception { + $undef_attr = Class::MOP::Attribute->new('$test' => ( + default => undef, + predicate => 'has_test', + )); + }, undef, '... undef as a default is okay' ); + ok($undef_attr->has_default, '... and it counts as an actual default'); + ok(!Class::MOP::Attribute->new('$test')->has_default, + '... but attributes with no default have no default'); + + Class::MOP::Class->create( + 'Foo', + attributes => [$undef_attr], + ); + { + my $obj = Foo->meta->new_object; + ok($obj->has_test, '... and the default is populated'); + is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); + } + is( exception { Foo->meta->make_immutable }, undef, '... and it can be inlined' ); + { + my $obj = Foo->new; + ok($obj->has_test, '... and the default is populated'); + is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); + } + +} + + +{ # bad construtor args + isnt( exception { + Class::MOP::Attribute->new(); + }, undef, '... no name argument' ); + + # These are no longer errors + is( exception { + Class::MOP::Attribute->new(''); + }, undef, '... bad name argument' ); + + is( exception { + Class::MOP::Attribute->new(0); + }, undef, '... bad name argument' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test'); + isnt( exception { + $attr->attach_to_class(); + }, undef, '... attach_to_class died as expected' ); + + isnt( exception { + $attr->attach_to_class('Fail'); + }, undef, '... attach_to_class died as expected' ); + + isnt( exception { + $attr->attach_to_class(bless {} => 'Fail'); + }, undef, '... attach_to_class died as expected' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test' => ( + reader => [ 'whoops, this wont work' ] + )); + + $attr->attach_to_class(Class::MOP::Class->initialize('Foo')); + + isnt( exception { + $attr->install_accessors; + }, undef, '... bad reader format' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test'); + + isnt( exception { + $attr->_process_accessors('fail', 'my_failing_sub'); + }, undef, '... cannot find "fail" type generator' ); +} + + +{ + { + package My::Attribute; + our @ISA = ('Class::MOP::Attribute'); + sub generate_reader_method { eval { die } } + } + + my $attr = My::Attribute->new('$test' => ( + reader => 'test' + )); + + isnt( exception { + $attr->install_accessors; + }, undef, '... failed to generate accessors correctly' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test' => ( + predicate => 'has_test' + )); + + my $Bar = Class::MOP::Class->create('Bar'); + isa_ok($Bar, 'Class::MOP::Class'); + + $Bar->add_attribute($attr); + + can_ok('Bar', 'has_test'); + + is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute'); + + ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method'); +} + + +{ + # NOTE: + # the next three tests once tested that + # the code would fail, but we lifted the + # restriction so you can have an accessor + # along with a reader/writer pair (I mean + # why not really). So now they test that + # it works, which is kinda silly, but it + # tests the API change, so I keep it. + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + )); + }, undef, '... can create accessors with reader/writers' ); + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + writer => 'set_foo', + )); + }, undef, '... can create accessors with reader/writers' ); + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + writer => 'set_foo', + )); + }, undef, '... can create accessors with reader/writers' ); +} + +done_testing; diff --git a/t/cmop/attribute_get_read_write.t b/t/cmop/attribute_get_read_write.t new file mode 100644 index 0000000..9f621a6 --- /dev/null +++ b/t/cmop/attribute_get_read_write.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Scalar::Util 'blessed', 'reftype'; + +use Test::More; + +use Class::MOP; + +=pod + +This checks the get_read/write_method +and get_read/write_method_ref methods + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + Foo->meta->add_attribute('baz' => + accessor => 'baz', + ); + + Foo->meta->add_attribute('gorch' => + reader => { 'get_gorch', => sub { (shift)->{gorch} } } + ); + + package Bar; + use metaclass; + Bar->meta->superclasses('Foo'); + + Bar->meta->add_attribute('quux' => + accessor => 'quux', + ); +} + +can_ok('Foo', 'get_bar'); +can_ok('Foo', 'set_bar'); +can_ok('Foo', 'baz'); +can_ok('Foo', 'get_gorch'); + +ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); +ok(Foo->meta->has_attribute('baz'), '... Foo has the attribute baz'); +ok(Foo->meta->has_attribute('gorch'), '... Foo has the attribute gorch'); + +my $bar_attr = Foo->meta->get_attribute('bar'); +my $baz_attr = Foo->meta->get_attribute('baz'); +my $gorch_attr = Foo->meta->get_attribute('gorch'); + +is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); +is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); +is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + +is($bar_attr->get_read_method, 'get_bar', '... $attr does have an read method'); +is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method'); + +{ + my $reader = $bar_attr->get_read_method_ref; + my $writer = $bar_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader->fully_qualified_name, 'Foo::get_bar', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::set_bar', '... it is the sub we are looking for'); + + is(reftype($reader->body), 'CODE', '... it is a plain old sub'); + is(reftype($writer->body), 'CODE', '... it is a plain old sub'); +} + +is($baz_attr->accessor, 'baz', '... the bar attribute has the accessor baz'); +is($baz_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + +is($baz_attr->get_read_method, 'baz', '... $attr does have an read method'); +is($baz_attr->get_write_method, 'baz', '... $attr does have an write method'); + +{ + my $reader = $baz_attr->get_read_method_ref; + my $writer = $baz_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader, $writer, '... they are the same method'); + + is($reader->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); +} + +is(ref($gorch_attr->reader), 'HASH', '... the gorch attribute has the reader get_gorch (HASH ref)'); +is($gorch_attr->associated_class, Foo->meta, '... and the gorch attribute is associated with Foo->meta'); + +is($gorch_attr->get_read_method, 'get_gorch', '... $attr does have an read method'); +ok(!$gorch_attr->get_write_method, '... $attr does not have an write method'); + +{ + my $reader = $gorch_attr->get_read_method_ref; + my $writer = $gorch_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + ok(blessed($writer), '... it is not a plain old sub'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for'); +} + +done_testing; diff --git a/t/cmop/attribute_initializer.t b/t/cmop/attribute_initializer.t new file mode 100644 index 0000000..7d8ca32 --- /dev/null +++ b/t/cmop/attribute_initializer.t @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Scalar::Util 'reftype'; +use Test::More; +use Class::MOP; + +=pod + +This checks that the initializer is used to set the initial value. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Class::MOP::Attribute'); + ::is($attr->name, 'bar', '... the attribute is our own'); + + $callback->($value * 2); + }, + ); +} + +can_ok('Foo', 'get_bar'); +can_ok('Foo', 'set_bar'); + +my $foo = Foo->meta->new_object(bar => 10); +is($foo->get_bar, 20, "... initial argument was doubled as expected"); + +$foo->set_bar(30); + +is($foo->get_bar, 30, "... and setter works correctly"); + +# meta tests ... + +my $bar = Foo->meta->get_attribute('bar'); +isa_ok($bar, 'Class::MOP::Attribute'); + +ok($bar->has_initializer, '... bar has an initializer'); +is(reftype $bar->initializer, 'CODE', '... the initializer is a CODE ref'); + +done_testing; diff --git a/t/cmop/attribute_introspection.t b/t/cmop/attribute_introspection.t new file mode 100644 index 0000000..dc99492 --- /dev/null +++ b/t/cmop/attribute_introspection.t @@ -0,0 +1,131 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +{ + my $attr = Class::MOP::Attribute->new('$test'); + is( $attr->meta, Class::MOP::Attribute->meta, + '... instance and class both lead to the same meta' ); +} + +{ + my $meta = Class::MOP::Attribute->meta(); + isa_ok( $meta, 'Class::MOP::Class' ); + + my @methods = qw( + new + clone + + initialize_instance_slot + _set_initial_slot_value + _make_initializer_writer_callback + + name + has_accessor accessor + has_writer writer + has_write_method get_write_method get_write_method_ref + has_reader reader + has_read_method get_read_method get_read_method_ref + has_predicate predicate + has_clearer clearer + has_builder builder + has_init_arg init_arg + has_default default is_default_a_coderef + has_initializer initializer + has_insertion_order insertion_order _set_insertion_order + + definition_context + + slots + get_value + set_value + get_raw_value + set_raw_value + set_initial_value + has_value + clear_value + + associated_class + attach_to_class + detach_from_class + + accessor_metaclass + + associated_methods + associate_method + + _process_accessors + _accessor_description + install_accessors + remove_accessors + + _inline_get_value + _inline_set_value + _inline_has_value + _inline_clear_value + _inline_instance_get + _inline_instance_set + _inline_instance_has + _inline_instance_clear + + _new + ); + + is_deeply( + [ + sort Class::MOP::Mixin::AttributeCore->meta->get_method_list, + $meta->get_method_list + ], + [ sort @methods ], + '... our method list matches' + ); + + foreach my $method_name (@methods) { + ok( $meta->find_method_by_name($method_name), + '... Class::MOP::Attribute->find_method_by_name(' . $method_name . ')' ); + } + + my @attributes = ( + 'name', + 'accessor', + 'reader', + 'writer', + 'predicate', + 'clearer', + 'builder', + 'init_arg', + 'initializer', + 'definition_context', + 'default', + 'associated_class', + 'associated_methods', + 'insertion_order', + ); + + is_deeply( + [ + sort Class::MOP::Mixin::AttributeCore->meta->get_attribute_list, + $meta->get_attribute_list + ], + [ sort @attributes ], + '... our attribute list matches' + ); + + foreach my $attribute_name (@attributes) { + ok( $meta->find_attribute_by_name($attribute_name), + '... Class::MOP::Attribute->find_attribute_by_name(' + . $attribute_name + . ')' ); + } + + # We could add some tests here to make sure that + # the attribute have the appropriate + # accessor/reader/writer/predicate combinations, + # but that is getting a little excessive so I + # wont worry about it for now. Maybe if I get + # bored I will do it. +} + +done_testing; diff --git a/t/cmop/attribute_non_alpha_name.t b/t/cmop/attribute_non_alpha_name.t new file mode 100644 index 0000000..98e411e --- /dev/null +++ b/t/cmop/attribute_non_alpha_name.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Class::MOP; + +use Test::More; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute( '@foo', accessor => 'foo' ); + Foo->meta->add_attribute( '!bar', reader => 'bar' ); + Foo->meta->add_attribute( '%baz', reader => 'baz' ); +} + +{ + my $meta = Foo->meta; + + for my $name ( '@foo', '!bar', '%baz' ) { + ok( + $meta->has_attribute($name), + "Foo has $name attribute" + ); + + my $meth = substr $name, 1; + ok( $meta->has_method($meth), 'Foo has $meth method' ); + } + + $meta->make_immutable, redo + unless $meta->is_immutable; +} + +done_testing; diff --git a/t/cmop/attributes.t b/t/cmop/attributes.t new file mode 100644 index 0000000..a6df570 --- /dev/null +++ b/t/cmop/attributes.t @@ -0,0 +1,262 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $FOO_ATTR = Class::MOP::Attribute->new('$foo'); +my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => ( + accessor => 'bar' +)); +my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( + reader => 'get_baz', + writer => 'set_baz', +)); + +my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar'); + +my $FOO_ATTR_2 = Class::MOP::Attribute->new('$foo' => ( + accessor => 'foo', + builder => 'build_foo' +)); + +is($FOO_ATTR->name, '$foo', '... got the attributes name correctly'); +is($BAR_ATTR->name, '$bar', '... got the attributes name correctly'); +is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); + +{ + package Foo; + use metaclass; + + my $meta = Foo->meta; + ::is( ::exception { + $meta->add_attribute($FOO_ATTR); + }, undef, '... we added an attribute to Foo successfully' ); + ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute'); + ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('foo'), '... no accessor created'); + + ::is( ::exception { + $meta->add_attribute($BAR_ATTR_2); + }, undef, '... we added an attribute to Foo successfully' ); + ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('bar'), '... no accessor created'); +} +{ + package Bar; + our @ISA = ('Foo'); + + my $meta = Bar->meta; + ::is( ::exception { + $meta->add_attribute($BAR_ATTR); + }, undef, '... we added an attribute to Bar successfully' ); + ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar'); + + my $attr = $meta->get_attribute('$bar'); + ::is($attr->get_read_method, 'bar', '... got the right read method for Bar'); + ::is($attr->get_write_method, 'bar', '... got the right write method for Bar'); + + ::ok($meta->has_method('bar'), '... an accessor has been created'); + ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor'); +} +{ + package Baz; + our @ISA = ('Bar'); + + my $meta = Baz->meta; + ::is( ::exception { + $meta->add_attribute($BAZ_ATTR); + }, undef, '... we added an attribute to Baz successfully' ); + ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute'); + ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz'); + + my $attr = $meta->get_attribute('$baz'); + ::is($attr->get_read_method, 'get_baz', '... got the right read method for Baz'); + ::is($attr->get_write_method, 'set_baz', '... got the right write method for Baz'); + + ::ok($meta->has_method('get_baz'), '... a reader has been created'); + ::ok($meta->has_method('set_baz'), '... a writer has been created'); + + ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor'); + ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor'); +} + +{ + package Foo2; + use metaclass; + + my $meta = Foo2->meta; + $meta->add_attribute( + Class::MOP::Attribute->new( '$foo2' => ( reader => 'foo2' ) ) ); + + ::ok( $meta->has_method('foo2'), '... a reader has been created' ); + + my $attr = $meta->get_attribute('$foo2'); + ::is( $attr->get_read_method, 'foo2', + '... got the right read method for Foo2' ); + ::is( $attr->get_write_method, undef, + '... got undef for the writer with a read-only attribute in Foo2' ); +} + +{ + my $meta = Baz->meta; + isa_ok($meta, 'Class::MOP::Class'); + + is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"'); + is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"'); + is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"'); + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR, + $BAZ_ATTR, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Bar->meta, Baz->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + my $attr; + is( exception { + $attr = $meta->remove_attribute('$baz'); + }, undef, '... removed the $baz attribute successfully' ); + is($attr, $BAZ_ATTR, '... got the right attribute back for Baz'); + + ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute'); + is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute'); + + ok(!$meta->has_method('get_baz'), '... a reader has been removed'); + ok(!$meta->has_method('set_baz'), '... a writer has been removed'); + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Bar->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + { + my $attr; + is( exception { + $attr = Bar->meta->remove_attribute('$bar'); + }, undef, '... removed the $bar attribute successfully' ); + is($attr, $BAR_ATTR, '... got the right attribute back for Bar'); + + ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute'); + + ok(!Bar->meta->has_method('bar'), '... a accessor has been removed'); + } + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR_2, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Foo->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + # remove attribute which is not there + my $val; + is( exception { + $val = $meta->remove_attribute('$blammo'); + }, undef, '... attempted to remove the non-existent $blammo attribute' ); + is($val, undef, '... got the right value back (undef)'); + +} + +{ + package Buzz; + use metaclass; + use Scalar::Util qw/blessed/; + + my $meta = Buzz->meta; + ::is( ::exception { + $meta->add_attribute($FOO_ATTR_2); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_attribute( + Class::MOP::Attribute->new( + '$bar' => ( + accessor => 'bar', + predicate => 'has_bar', + clearer => 'clear_bar', + ) + ) + ); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_attribute( + Class::MOP::Attribute->new( + '$bah' => ( + accessor => 'bah', + predicate => 'has_bah', + clearer => 'clear_bah', + default => 'BAH', + ) + ) + ); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_method(build_foo => sub{ blessed shift; }); + }, undef, '... we added a method to Buzz successfully' ); +} + + + +for(1 .. 2){ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::is($buzz->foo, 'Buzz', '...foo builder works as expected'); + ::ok(!$buzz->has_bar, '...bar is not set'); + ::is($buzz->bar, undef, '...bar returns undef'); + ::ok(!$buzz->has_bar, '...bar was not autovivified'); + + $buzz->bar(undef); + ::ok($buzz->has_bar, '...bar is set'); + ::is($buzz->bar, undef, '...bar is undef'); + $buzz->clear_bar; + ::ok(!$buzz->has_bar, '...bar is no longerset'); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('$bar' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bar, '...bar is set'); + ::is($buzz2->bar, undef, '...bar is undef'); + + my $buzz3; + ::is( ::exception { $buzz3 = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz3->has_bah, '...bah is set'); + ::is($buzz3->bah, 'BAH', '...bah returns "BAH" '); + + my $buzz4; + ::is( ::exception { $buzz4 = Buzz->meta->new_object('$bah' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz4->has_bah, '...bah is set'); + ::is($buzz4->bah, undef, '...bah is undef'); + + Buzz->meta->make_immutable(); +} + +done_testing; diff --git a/t/cmop/basic.t b/t/cmop/basic.t new file mode 100644 index 0000000..984b251 --- /dev/null +++ b/t/cmop/basic.t @@ -0,0 +1,78 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; +use Class::MOP::Class; + +{ + package Foo; + use metaclass; + our $VERSION = '0.01'; + + package Bar; + our @ISA = ('Foo'); + + our $AUTHORITY = 'cpan:JRANDOM'; +} + +my $Foo = Foo->meta; +isa_ok($Foo, 'Class::MOP::Class'); + +my $Bar = Bar->meta; +isa_ok($Bar, 'Class::MOP::Class'); + +is($Foo->name, 'Foo', '... Foo->name == Foo'); +is($Bar->name, 'Bar', '... Bar->name == Bar'); + +is($Foo->version, '0.01', '... Foo->version == 0.01'); +is($Bar->version, undef, '... Bar->version == undef'); + +is($Foo->authority, undef, '... Foo->authority == undef'); +is($Bar->authority, 'cpan:JRANDOM', '... Bar->authority == cpan:JRANDOM'); + +is($Foo->identifier, 'Foo-0.01', '... Foo->identifier == Foo-0.01'); +is($Bar->identifier, 'Bar-cpan:JRANDOM', '... Bar->identifier == Bar-cpan:JRANDOM'); + +is_deeply([$Foo->superclasses], [], '... Foo has no superclasses'); +is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)'); + +$Foo->superclasses('UNIVERSAL'); + +is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now'); + +is_deeply( + [ $Foo->class_precedence_list ], + [ 'Foo', 'UNIVERSAL' ], + '... Foo->class_precedence_list == (Foo, UNIVERSAL)'); + +is_deeply( + [ $Bar->class_precedence_list ], + [ 'Bar', 'Foo', 'UNIVERSAL' ], + '... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)'); + +# create a class using Class::MOP::Class ... + +my $Baz = Class::MOP::Class->create( + 'Baz' => ( + version => '0.10', + authority => 'cpan:YOMAMA', + superclasses => [ 'Bar' ] + )); +isa_ok($Baz, 'Class::MOP::Class'); +is(Baz->meta, $Baz, '... our metaclasses are singletons'); + +is($Baz->name, 'Baz', '... Baz->name == Baz'); +is($Baz->version, '0.10', '... Baz->version == 0.10'); +is($Baz->authority, 'cpan:YOMAMA', '... Baz->authority == YOMAMA'); + +is($Baz->identifier, 'Baz-0.10-cpan:YOMAMA', '... Baz->identifier == Baz-0.10-cpan:YOMAMA'); + +is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)'); + +is_deeply( + [ $Baz->class_precedence_list ], + [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ], + '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)'); + +done_testing; diff --git a/t/cmop/before_after_dollar_under.t b/t/cmop/before_after_dollar_under.t new file mode 100644 index 0000000..65f9774 --- /dev/null +++ b/t/cmop/before_after_dollar_under.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Class::MOP; +use Class::MOP::Class; +use Test::More; +use Test::Fatal; + +my %results; + +{ + + package Base; + use metaclass; + sub hey { $results{base}++ } +} + +for my $wrap (qw(before after)) { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => [ 'Base', 'Class::MOP::Object' ] ); + my $alter = "add_${wrap}_method_modifier"; + $meta->$alter( + 'hey' => sub { + $results{wrapped}++; + $_ = 'barf'; # 'barf' would replace the cached wrapper subref + } + ); + + %results = (); + my $o = $meta->get_meta_instance->create_instance; + isa_ok( $o, 'Base' ); + is( exception { + $o->hey; + $o->hey + ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' + }, undef, 'wrapped doesn\'t die when $_ gets changed' ); + is_deeply( + \%results, { base => 2, wrapped => 2 }, + 'saw expected calls to wrappers' + ); +} + +{ + my $meta = Class::MOP::Class->create_anon_class( + superclasses => [ 'Base', 'Class::MOP::Object' ] ); + for my $wrap (qw(before after)) { + my $alter = "add_${wrap}_method_modifier"; + $meta->$alter( + 'hey' => sub { + $results{wrapped}++; + $_ = 'barf'; # 'barf' would replace the cached wrapper subref + } + ); + } + + %results = (); + my $o = $meta->get_meta_instance->create_instance; + isa_ok( $o, 'Base' ); + is( exception { + $o->hey; + $o->hey + ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' + }, undef, 'double-wrapped doesn\'t die when $_ gets changed' ); + is_deeply( + \%results, { base => 2, wrapped => 4 }, + 'saw expected calls to wrappers' + ); +} + +done_testing; diff --git a/t/cmop/class_errors_and_edge_cases.t b/t/cmop/class_errors_and_edge_cases.t new file mode 100644 index 0000000..51810a3 --- /dev/null +++ b/t/cmop/class_errors_and_edge_cases.t @@ -0,0 +1,222 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + isnt( exception { + Class::MOP::Class->initialize(); + }, undef, '... initialize requires a name parameter' ); + + isnt( exception { + Class::MOP::Class->initialize(''); + }, undef, '... initialize requires a name valid parameter' ); + + isnt( exception { + Class::MOP::Class->initialize(bless {} => 'Foo'); + }, undef, '... initialize requires an unblessed parameter' ); +} + +{ + isnt( exception { + Class::MOP::Class->_construct_class_instance(); + }, undef, '... _construct_class_instance requires an :package parameter' ); + + isnt( exception { + Class::MOP::Class->_construct_class_instance(':package' => undef); + }, undef, '... _construct_class_instance requires a defined :package parameter' ); + + isnt( exception { + Class::MOP::Class->_construct_class_instance(':package' => ''); + }, undef, '... _construct_class_instance requires a valid :package parameter' ); +} + + +{ + isnt( exception { + Class::MOP::Class->create(); + }, undef, '... create requires an package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create(undef); + }, undef, '... create requires a defined package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create(''); + }, undef, '... create requires a valid package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create('+++'); + }, qr/^\+\+\+ is not a module name/, '... create requires a valid package_name parameter' ); +} + +{ + isnt( exception { + Class::MOP::Class->clone_object(1); + }, undef, '... can only clone instances' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_method(); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method(''); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method('foo' => 'foo'); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method('foo' => []); + }, undef, '... add_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->has_method(); + }, undef, '... has_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_method(''); + }, undef, '... has_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_method(); + }, undef, '... get_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_method(''); + }, undef, '... get_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_method(); + }, undef, '... remove_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_method(''); + }, undef, '... remove_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->find_all_methods_by_name(); + }, undef, '... find_all_methods_by_name dies as expected' ); + + isnt( exception { + Class::MOP::Class->find_all_methods_by_name(''); + }, undef, '... find_all_methods_by_name dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_attribute(bless {} => 'Foo'); + }, undef, '... add_attribute dies as expected' ); +} + + +{ + isnt( exception { + Class::MOP::Class->has_attribute(); + }, undef, '... has_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_attribute(''); + }, undef, '... has_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_attribute(); + }, undef, '... get_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_attribute(''); + }, undef, '... get_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_attribute(); + }, undef, '... remove_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_attribute(''); + }, undef, '... remove_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_package_symbol(); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol(''); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol('foo'); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol('&foo'); + }, undef, '... add_package_symbol dies as expected' ); + +# throws_ok { +# Class::MOP::Class->meta->add_package_symbol('@-'); +# } qr/^Could not create package variable \(\@\-\) because/, +# '... add_package_symbol dies as expected'; +} + +{ + isnt( exception { + Class::MOP::Class->has_package_symbol(); + }, undef, '... has_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_package_symbol(''); + }, undef, '... has_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_package_symbol('foo'); + }, undef, '... has_package_symbol dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_package_symbol(); + }, undef, '... get_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_package_symbol(''); + }, undef, '... get_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_package_symbol('foo'); + }, undef, '... get_package_symbol dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_package_symbol(); + }, undef, '... remove_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_package_symbol(''); + }, undef, '... remove_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_package_symbol('foo'); + }, undef, '... remove_package_symbol dies as expected' ); +} + +done_testing; diff --git a/t/cmop/class_is_pristine.t b/t/cmop/class_is_pristine.t new file mode 100644 index 0000000..4ab95c0 --- /dev/null +++ b/t/cmop/class_is_pristine.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Class::MOP; +use Test::More; + +{ + package Foo; + + sub foo { } + sub bar { } +} + +my $meta = Class::MOP::Class->initialize('Foo'); +ok( $meta->is_pristine, 'Foo is still pristine' ); + +$meta->add_method( baz => sub { } ); +ok( $meta->is_pristine, 'Foo is still pristine after add_method' ); + +$meta->add_attribute( name => 'attr', reader => 'get_attr' ); +ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' ); + +done_testing; diff --git a/t/cmop/class_precedence_list.t b/t/cmop/class_precedence_list.t new file mode 100644 index 0000000..56ef28f --- /dev/null +++ b/t/cmop/class_precedence_list.t @@ -0,0 +1,160 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; +use Class::MOP::Class; + +=pod + + A + / \ +B C + \ / + D + +=cut + +{ + package My::A; + use metaclass; + package My::B; + our @ISA = ('My::A'); + package My::C; + our @ISA = ('My::A'); + package My::D; + our @ISA = ('My::B', 'My::C'); +} + +is_deeply( + [ My::D->meta->class_precedence_list ], + [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], + '... My::D->meta->class_precedence_list == (D B A C A)'); + +is_deeply( + [ My::D->meta->linearized_isa ], + [ 'My::D', 'My::B', 'My::A', 'My::C' ], + '... My::D->meta->linearized_isa == (D B A C)'); + +=pod + + A <-+ + | | + B | + | | + C --+ + +=cut + +# 5.9.5+ dies at the moment of +# recursive @ISA definition, not later when +# you try to use the @ISAs. +eval { + { + package My::2::A; + use metaclass; + our @ISA = ('My::2::C'); + + package My::2::B; + our @ISA = ('My::2::A'); + + package My::2::C; + our @ISA = ('My::2::B'); + } + + My::2::B->meta->class_precedence_list +}; +ok($@, '... recursive inheritance breaks correctly :)'); + +=pod + + +--------+ + | A | + | / \ | + +->B C-+ + \ / + D + +=cut + +{ + package My::3::A; + use metaclass; + package My::3::B; + our @ISA = ('My::3::A'); + package My::3::C; + our @ISA = ('My::3::A', 'My::3::B'); + package My::3::D; + our @ISA = ('My::3::B', 'My::3::C'); +} + +is_deeply( + [ My::3::D->meta->class_precedence_list ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], + '... My::3::D->meta->class_precedence_list == (D B A C A B A)'); + +is_deeply( + [ My::3::D->meta->linearized_isa ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ], + '... My::3::D->meta->linearized_isa == (D B A C B)'); + +=pod + +Test all the class_precedence_lists +using Perl's own dispatcher to check +against. + +=cut + +my @CLASS_PRECEDENCE_LIST; + +{ + package Foo; + use metaclass; + + sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' } + + package Bar; + our @ISA = ('Foo'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Bar'; + $_[0]->SUPER::CPL(); + } + + package Baz; + use metaclass; + our @ISA = ('Bar'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Baz'; + $_[0]->SUPER::CPL(); + } + + package Foo::Bar; + our @ISA = ('Baz'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Foo::Bar'; + $_[0]->SUPER::CPL(); + } + + package Foo::Bar::Baz; + our @ISA = ('Foo::Bar'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz'; + $_[0]->SUPER::CPL(); + } + +} + +Foo::Bar::Baz->CPL(); + +is_deeply( + [ Foo::Bar::Baz->meta->class_precedence_list ], + [ @CLASS_PRECEDENCE_LIST ], + '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST'); + +done_testing; diff --git a/t/cmop/constant_codeinfo.t b/t/cmop/constant_codeinfo.t new file mode 100644 index 0000000..b40cc82 --- /dev/null +++ b/t/cmop/constant_codeinfo.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; + +{ + package Foo; + use constant FOO => 'bar'; +} + +my $meta = Class::MOP::Class->initialize('Foo'); + +my $syms = $meta->get_all_package_symbols('CODE'); +is(ref $syms->{FOO}, 'CODE', 'get constant symbol'); + +undef $syms; + +$syms = $meta->get_all_package_symbols('CODE'); +is(ref $syms->{FOO}, 'CODE', 'constant symbol still there, although we dropped our reference'); + +done_testing; diff --git a/t/cmop/create_class.t b/t/cmop/create_class.t new file mode 100644 index 0000000..63a31d4 --- /dev/null +++ b/t/cmop/create_class.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } +)); + +my $Point3D = Class::MOP::Class->create('Point3D' => ( + version => '0.01', + superclasses => [ 'Point' ], + attributes => [ + Class::MOP::Attribute->new('z' => ( + default => 123 + )), + ], + methods => { + 'clear' => sub { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } + } +)); + +isa_ok($Point, 'Class::MOP::Class'); +isa_ok($Point3D, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the y attribute was set properly with the accessor'); + +is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); + +isnt( exception { + $point->x(42); +}, undef, '... cannot write to a read-only accessor' ); +is($point->x, 2, '... the x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the y attribute was cleared correctly'); +is($point->x, 0, '... the x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); +is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the x attribute was not initialized'); + is($point3d->y, undef, '... the y attribute was not initialized'); + is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); + +} + +done_testing; diff --git a/t/cmop/custom_instance.t b/t/cmop/custom_instance.t new file mode 100644 index 0000000..c6aeb6d --- /dev/null +++ b/t/cmop/custom_instance.t @@ -0,0 +1,137 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $instance; +{ + package Foo; + + sub new { + my $class = shift; + $instance = bless {@_}, $class; + return $instance; + } + + sub foo { shift->{foo} } +} + +{ + package Foo::Sub; + use parent -norequire => 'Foo'; + use metaclass; + + sub new { + my $class = shift; + $class->meta->new_object( + __INSTANCE__ => $class->SUPER::new(@_), + @_, + ); + } + + __PACKAGE__->meta->add_attribute( + bar => ( + reader => 'bar', + initializer => sub { + my $self = shift; + my ($value, $writer, $attr) = @_; + $writer->(uc $value); + }, + ), + ); +} + +undef $instance; +is( exception { + my $foo = Foo::Sub->new; + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(foo => 'FOO'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->foo, 'FOO', "set non-CMOP constructor args"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(bar => 'bar'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->bar, 'BAR', "set CMOP attributes"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->foo, 'FOO', "set non-CMOP constructor arg"); + is($foo->bar, 'BAR', "set correct CMOP attribute"); +}, undef ); + +{ + package BadFoo; + + sub new { + my $class = shift; + $instance = bless {@_}; + return $instance; + } + + sub foo { shift->{foo} } +} + +{ + package BadFoo::Sub; + use parent -norequire => 'BadFoo'; + use metaclass; + + sub new { + my $class = shift; + $class->meta->new_object( + __INSTANCE__ => $class->SUPER::new(@_), + @_, + ); + } + + __PACKAGE__->meta->add_attribute( + bar => ( + reader => 'bar', + initializer => sub { + my $self = shift; + my ($value, $writer, $attr) = @_; + $writer->(uc $value); + }, + ), + ); +} + +like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" ); + +{ + my $meta = Class::MOP::Class->create('Really::Bad::Foo'); + like( exception { + $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class')) + }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" ); +} + +{ + my $meta = Class::MOP::Class->create('Really::Bad::Foo::2'); + for my $invalid ('foo', 1, 0, '') { + like( exception { + $meta->new_object(__INSTANCE__ => $invalid) + }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" ); + } +} + +done_testing; diff --git a/t/cmop/deprecated.t b/t/cmop/deprecated.t new file mode 100644 index 0000000..b29649b --- /dev/null +++ b/t/cmop/deprecated.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + Class::MOP::load_class('BinaryTree'); + like($warnings, qr/^Class::MOP::load_class is deprecated/); + ok(Class::MOP::does_metaclass_exist('BinaryTree')); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + ok(Class::MOP::is_class_loaded('BinaryTree')); + like($warnings, qr/^Class::MOP::is_class_loaded is deprecated/); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + is(Class::MOP::load_first_existing_class('this::class::probably::doesnt::exist', 'MyMetaClass'), 'MyMetaClass'); + like($warnings, qr/^Class::MOP::load_first_existing_class is deprecated/); +} + +done_testing; diff --git a/t/cmop/get_code_info.t b/t/cmop/get_code_info.t new file mode 100644 index 0000000..2770b76 --- /dev/null +++ b/t/cmop/get_code_info.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Sub::Name 'subname'; + +BEGIN { + $^P &= ~0x200; # Don't munge anonymous sub names +} + +use Class::MOP; + + +sub code_name_is { + my ( $code, $stash, $name ) = @_; + + is_deeply( + [ Class::MOP::get_code_info($code) ], + [ $stash, $name ], + "sub name is ${stash}::$name" + ); +} + +code_name_is( sub {}, main => "__ANON__" ); + +code_name_is( subname("Foo::bar", sub {}), Foo => "bar" ); + +code_name_is( subname("", sub {}), "main" => "" ); + +require Class::MOP::Method; +code_name_is( \&Class::MOP::Method::name, "Class::MOP::Method", "name" ); + +{ + package Foo; + + sub MODIFY_CODE_ATTRIBUTES { + my ($class, $code) = @_; + my @info = Class::MOP::get_code_info($code); + + if ( $] >= 5.011 ) { + ::is_deeply(\@info, ['Foo', 'foo'], "got a name for a code ref in an attr handler"); + } + else { + ::is_deeply(\@info, [], "no name for a coderef that's still compiling"); + } + return (); + } + + sub foo : Bar {} +} + +done_testing; diff --git a/t/cmop/immutable_custom_trait.t b/t/cmop/immutable_custom_trait.t new file mode 100644 index 0000000..24b72b7 --- /dev/null +++ b/t/cmop/immutable_custom_trait.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + + package My::Meta; + + use strict; + use warnings; + + use parent 'Class::MOP::Class'; + + sub initialize { + shift->SUPER::initialize( + @_, + immutable_trait => 'My::Meta::Class::Immutable::Trait', + ); + } +} + +{ + package My::Meta::Class::Immutable::Trait; + + use MRO::Compat; + use parent 'Class::MOP::Class::Immutable::Trait'; + + sub another_method { 42 } + + sub superclasses { + my $orig = shift; + my $self = shift; + $self->$orig(@_); + } +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('foo'); + + __PACKAGE__->meta->make_immutable; +} + +{ + package Bar; + + use strict; + use warnings; + use metaclass 'My::Meta'; + + use parent -norequire => 'Foo'; + + __PACKAGE__->meta->add_attribute('bar'); + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'can safely make a class immutable when it has a custom metaclass and immutable trait' ); +} + +{ + can_ok( Bar->meta, 'another_method' ); + is( Bar->meta->another_method, 42, 'another_method returns expected value' ); + is_deeply( + [ Bar->meta->superclasses ], ['Foo'], + 'Bar->meta->superclasses returns expected value after immutabilization' + ); +} + +done_testing; diff --git a/t/cmop/immutable_metaclass.t b/t/cmop/immutable_metaclass.t new file mode 100644 index 0000000..e674f34 --- /dev/null +++ b/t/cmop/immutable_metaclass.t @@ -0,0 +1,300 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Foo->meta; + my $original_metaclass_name = ref $meta; + + is_deeply( + { $meta->immutable_options }, {}, + 'immutable_options is empty before a class is made_immutable' + ); + + ok( $meta->make_immutable, 'make_immutable returns true' ); + my $line = __LINE__ - 1; + + ok( $meta->make_immutable, 'make_immutable still returns true' ); + + my $immutable_metaclass = $meta->_immutable_metaclass->meta; + + my $immutable_class_name = $immutable_metaclass->name; + + ok( !$immutable_class_name->is_mutable, '... immutable_metaclass is not mutable' ); + ok( $immutable_class_name->is_immutable, '... immutable_metaclass is immutable' ); + is( $immutable_class_name->meta, $immutable_metaclass, + '... immutable_metaclass meta hack works' ); + + is_deeply( + { $meta->immutable_options }, + { + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => 'Class::MOP::Class::Immutable::Trait', + constructor_name => 'new', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => undef, + file => $0, + line => $line, + }, + 'immutable_options is empty before a class is made_immutable' + ); + + isa_ok( $meta, "Class::MOP::Class" ); +} + +{ + my $meta = Foo->meta; + is( $meta->name, 'Foo', '... checking the Foo metaclass' ); + + ok( !$meta->is_mutable, '... our class is not mutable' ); + ok( $meta->is_immutable, '... our class is immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + is( exception { $meta->identifier() }, undef, '... no exception for get_package_symbol special case' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + ['Foo'], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + \@attributes, + [ $meta->get_attribute('bar') ], + '... got the right list of attributes' + ); +} + +{ + my $meta = Bar->meta; + is( $meta->name, 'Bar', '... checking the Bar metaclass' ); + + ok( $meta->is_mutable, '... our class is mutable' ); + ok( !$meta->is_immutable, '... our class is not immutable' ); + + is( exception { + $meta->make_immutable(); + }, undef, '... changed Bar to be immutable' ); + + ok( $meta->make_immutable, '... make immutable returns true' ); + + ok( !$meta->is_mutable, '... our class is no longer mutable' ); + ok( $meta->is_immutable, '... our class is now immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + [ 'Bar', 'Foo' ], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ Foo->meta->get_attribute('bar'), $meta->get_attribute('baz') ], + '... got the right list of attributes' + ); +} + +{ + my $meta = Baz->meta; + is( $meta->name, 'Baz', '... checking the Baz metaclass' ); + + ok( $meta->is_mutable, '... our class is mutable' ); + ok( !$meta->is_immutable, '... our class is not immutable' ); + + is( exception { + $meta->make_immutable(); + }, undef, '... changed Baz to be immutable' ); + + ok( $meta->make_immutable, '... make immutable returns true' ); + + ok( !$meta->is_mutable, '... our class is no longer mutable' ); + ok( $meta->is_immutable, '... our class is now immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + [ 'Baz', 'Bar', 'Foo' ], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ + $meta->get_attribute('bah'), Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('baz') + ], + '... got the right list of attributes' + ); +} + +# This test probably needs to go last since it will muck up the Foo class +{ + my $meta = Foo->meta; + + $meta->make_mutable; + $meta->make_immutable( + inline_accessors => 0, + inline_constructor => 0, + constructor_name => 'newer', + ); + my $line = __LINE__ - 5; + + is_deeply( + { $meta->immutable_options }, + { + inline_accessors => 0, + inline_constructor => 0, + inline_destructor => 0, + debug => 0, + immutable_trait => 'Class::MOP::Class::Immutable::Trait', + constructor_name => 'newer', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => undef, + file => $0, + line => $line, + }, + 'custom immutable_options are returned by immutable_options accessor' + ); +} + +done_testing; diff --git a/t/cmop/immutable_w_constructors.t b/t/cmop/immutable_w_constructors.t new file mode 100644 index 0000000..cb95e20 --- /dev/null +++ b/t/cmop/immutable_w_constructors.t @@ -0,0 +1,301 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar' => ( + reader => 'bar', + default => 'BAR', + )); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz' => ( + reader => 'baz', + default => sub { 'BAZ' }, + )); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah' => ( + reader => 'bah', + default => 'BAH', + )); + + package Buzz; + + use strict; + use warnings; + use metaclass; + + + __PACKAGE__->meta->add_attribute('bar' => ( + accessor => 'bar', + predicate => 'has_bar', + clearer => 'clear_bar', + )); + + __PACKAGE__->meta->add_attribute('bah' => ( + accessor => 'bah', + predicate => 'has_bah', + clearer => 'clear_bah', + default => 'BAH' + )); + +} + +{ + my $meta = Foo->meta; + is($meta->name, 'Foo', '... checking the Foo metaclass'); + + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 0, + ); + }, undef, '... changed Foo to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Foo', 'new'); + + { + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAR', '... got the right default value'); + } + + { + my $foo = Foo->new(bar => 'BAZ'); + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAZ', '... got the right parameter value'); + } + + # NOTE: + # check that the constructor correctly handles inheritance + { + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Foo'); + is($bar->bar, 'BAR', '... got the right inherited parameter value'); + is($bar->baz, 'BAZ', '... got the right inherited parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + } +} + +{ + my $meta = Bar->meta; + is($meta->name, 'Bar', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 1, + ); + }, undef, '... changed Bar to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Bar', 'new'); + + { + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAR', '... got the right default value'); + is($bar->baz, 'BAZ', '... got the right default value'); + } + + { + my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!'); + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAZ!', '... got the right parameter value'); + is($bar->baz, 'BAR!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 0, + inline_accessors => 1, + ); + }, undef, '... changed Bar to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + ok(!Baz->meta->has_method('new'), '... no constructor was made'); + + { + my $baz = Baz->meta->new_object; + isa_ok($baz, 'Bar'); + is($baz->bar, 'BAR', '... got the right default value'); + is($baz->baz, 'BAZ', '... got the right default value'); + } + + { + my $baz = Baz->meta->new_object(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!'); + isa_ok($baz, 'Baz'); + is($baz->bar, 'BAZ!', '... got the right parameter value'); + is($baz->baz, 'BAR!', '... got the right parameter value'); + is($baz->bah, 'BAH!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok($bah_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + + +{ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok(!$buzz->has_bar, '...bar is not set'); + ::is($buzz->bar, undef, '...bar returns undef'); + ::ok(!$buzz->has_bar, '...bar was not autovivified'); + + $buzz->bar(undef); + ::ok($buzz->has_bar, '...bar is set'); + ::is($buzz->bar, undef, '...bar is undef'); + $buzz->clear_bar; + ::ok(!$buzz->has_bar, '...bar is no longerset'); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('bar' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bar, '...bar is set'); + ::is($buzz2->bar, undef, '...bar is undef'); + +} + +{ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz->has_bah, '...bah is set'); + ::is($buzz->bah, 'BAH', '...bah returns "BAH"' ); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('bah' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bah, '...bah is set'); + ::is($buzz2->bah, undef, '...bah is undef'); + +} + +done_testing; diff --git a/t/cmop/immutable_w_custom_metaclass.t b/t/cmop/immutable_w_custom_metaclass.t new file mode 100644 index 0000000..c0b722d --- /dev/null +++ b/t/cmop/immutable_w_custom_metaclass.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util; + +use Class::MOP; + +use lib 't/cmop/lib'; + +{ + + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->make_immutable; + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->make_immutable; + + package Baz; + + use strict; + use warnings; + use metaclass 'MyMetaClass'; + + sub mymetaclass_attributes { + shift->meta->mymetaclass_attributes; + } + + ::is( ::exception { Baz->meta->superclasses('Bar') }, undef, '... we survive the metaclass incompatibility test' ); +} + +{ + my $meta = Baz->meta; + ok( $meta->is_mutable, '... Baz is mutable' ); + is( + Scalar::Util::blessed( Foo->meta ), + Scalar::Util::blessed( Bar->meta ), + 'Foo and Bar immutable metaclasses match' + ); + is( Scalar::Util::blessed($meta), 'MyMetaClass', + 'Baz->meta blessed as MyMetaClass' ); + ok( Baz->can('mymetaclass_attributes'), + '... Baz can do method before immutable' ); + ok( $meta->can('mymetaclass_attributes'), + '... meta can do method before immutable' ); + is( exception { $meta->make_immutable }, undef, "Baz is now immutable" ); + ok( $meta->is_immutable, '... Baz is immutable' ); + isa_ok( $meta, 'MyMetaClass', 'Baz->meta' ); + ok( Baz->can('mymetaclass_attributes'), + '... Baz can do method after imutable' ); + ok( $meta->can('mymetaclass_attributes'), + '... meta can do method after immutable' ); + isnt( Scalar::Util::blessed( Baz->meta ), + Scalar::Util::blessed( Bar->meta ), + 'Baz and Bar immutable metaclasses are different' ); + is( exception { $meta->make_mutable }, undef, "Baz is now mutable" ); + ok( $meta->is_mutable, '... Baz is mutable again' ); +} + +done_testing; diff --git a/t/cmop/inline_and_dollar_at.t b/t/cmop/inline_and_dollar_at.t new file mode 100644 index 0000000..80af4c9 --- /dev/null +++ b/t/cmop/inline_and_dollar_at.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + + +{ + package Foo; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $@ = 'dollar at'; + + $meta->make_immutable; + + ::is( $@, 'dollar at', '$@ is untouched after immutablization' ); +} + +done_testing; diff --git a/t/cmop/inline_structor.t b/t/cmop/inline_structor.t new file mode 100644 index 0000000..b22c8a9 --- /dev/null +++ b/t/cmop/inline_structor.t @@ -0,0 +1,291 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +use Class::MOP; + +{ + package HasConstructor; + + sub new { bless {}, $_[0] } + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/, + 'got a warning that Foo will not have an inlined constructor because it defines its own new method' + ); + + ::is( + $meta->find_method_by_name('new')->body, + HasConstructor->can('new'), + 'HasConstructor->new was untouched' + ); +} + +{ + package My::Constructor; + + use parent 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'Base::Class' } +} + +{ + package No::Constructor; +} + +{ + package My::Constructor2; + + use parent 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'No::Constructor' } +} + +{ + package Base::Class; + + sub new { bless {}, $_[0] } + sub DESTROY { } +} + +{ + package NotMoose; + + sub new { + my $class = shift; + + return bless { not_moose => 1 }, $class; + } +} + +{ + package Foo; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) }, + qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, + 'got a warning that Foo will not have an inlined constructor' + ); + + ::is( + $meta->find_method_by_name('new')->body, + NotMoose->can('new'), + 'Foo->new is inherited from NotMoose' + ); +} + +{ + package Bar; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_is( + sub { $meta->make_immutable( replace_constructor => 1 ) }, + q{}, + 'no warning when replace_constructor is true' + ); + + ::is( + $meta->find_method_by_name('new')->package_name, + 'Bar', + 'Bar->new is inlined, and not inherited from NotMoose' + ); +} + +{ + package Baz; + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable; +} + +{ + package Quux; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('Baz'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package Whatever; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) }, + qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/, + 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist' + ); +} + +{ + package My::Constructor3; + + use parent 'Class::MOP::Method::Constructor'; +} + +{ + package CustomCons; + + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' ); +} + +{ + package Subclass; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('CustomCons'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package ModdedNew; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub new { bless {}, shift } + + $meta->add_before_method_modifier( 'new' => sub { } ); +} + +{ + package ModdedSub; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('ModdedNew'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/, + 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new' + ); +} + +{ + package My::Destructor; + + use parent 'Class::MOP::Method::Inlined'; + + sub new { + my $class = shift; + my %options = @_; + + my $self = bless \%options, $class; + $self->_inline_destructor; + + return $self; + } + + sub _inline_destructor { + my $self = shift; + + my $code = $self->_compile_code('sub { }'); + + $self->{body} = $code; + } + + sub is_needed { 1 } + sub associated_metaclass { $_[0]->{metaclass} } + sub body { $_[0]->{body} } + sub _expected_method_class { 'Base::Class' } +} + +{ + package HasDestructor; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining a destructor for HasDestructor since it defines its own destructor./, + 'got a warning when trying to inline a destructor for a class that already defines DESTROY' + ); + + ::is( + $meta->find_method_by_name('DESTROY')->body, + HasDestructor->can('DESTROY'), + 'HasDestructor->DESTROY was untouched' + ); +} + +{ + package HasDestructor2; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + + ::stderr_is( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + }, + q{}, + 'no warning when replace_destructor is true' + ); + + ::isnt( + $meta->find_method_by_name('new')->body, + HasConstructor2->can('new'), + 'HasConstructor2->new was replaced' + ); +} + +{ + package ParentHasDestructor; + + sub DESTROY { } +} + +{ + package DestructorChild; + + use parent -norequire => 'ParentHasDestructor'; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/, + 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY' + ); +} + +done_testing; diff --git a/t/cmop/insertion_order.t b/t/cmop/insertion_order.t new file mode 100644 index 0000000..073d3b3 --- /dev/null +++ b/t/cmop/insertion_order.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } +)); + +is($Point->get_attribute('x')->insertion_order, 0, 'Insertion order of Attribute "x"'); +is($Point->get_attribute('y')->insertion_order, 1, 'Insertion order of Attribute "y"'); + +done_testing; diff --git a/t/cmop/instance.t b/t/cmop/instance.t new file mode 100644 index 0000000..943d6bb --- /dev/null +++ b/t/cmop/instance.t @@ -0,0 +1,137 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util qw/isweak reftype/; + +use Class::MOP::Instance; + +can_ok( "Class::MOP::Instance", $_ ) for qw/ + new + + create_instance + + get_all_slots + + initialize_all_slots + deinitialize_all_slots + + get_slot_value + set_slot_value + initialize_slot + deinitialize_slot + is_slot_initialized + weaken_slot_value + strengthen_slot_value + + inline_get_slot_value + inline_set_slot_value + inline_initialize_slot + inline_deinitialize_slot + inline_is_slot_initialized + inline_weaken_slot_value + inline_strengthen_slot_value +/; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('moosen'); + + package Bar; + use metaclass; + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('elken'); +} + +my $mi_foo = Foo->meta->get_meta_instance; +isa_ok($mi_foo, "Class::MOP::Instance"); + +is_deeply( + [ $mi_foo->get_all_slots ], + [ "moosen" ], + '... get all slots for Foo'); + +my $mi_bar = Bar->meta->get_meta_instance; +isa_ok($mi_bar, "Class::MOP::Instance"); + +isnt($mi_foo, $mi_bar, '... they are not the same instance'); + +is_deeply( + [ sort $mi_bar->get_all_slots ], + [ "elken", "moosen" ], + '... get all slots for Bar'); + +my $i_foo = $mi_foo->create_instance; +isa_ok($i_foo, "Foo"); + +{ + my $i_foo_2 = $mi_foo->create_instance; + isa_ok($i_foo_2, "Foo"); + isnt($i_foo_2, $i_foo, '... not the same instance'); + is_deeply($i_foo, $i_foo_2, '... but the same structure'); +} + +ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot not initialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); + +$mi_foo->initialize_slot( $i_foo, "moosen" ); + +#Removed becayse slot initialization works differently now (groditi) +#ok($mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot initialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... but no value for slot"); + +$mi_foo->set_slot_value( $i_foo, "moosen", "the value" ); + +is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value"); +ok(!$i_foo->can('moosen'), '... Foo cant moosen'); + +my $ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); + +ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), $ref, "weak value is fetchable" ); +ok( !isweak($mi_foo->get_slot_value( $i_foo, "moosen" )), "return value not weak" ); + +undef $ref; + +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); + +$ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); + +undef $ref; + +is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "value not weak yet" ); + +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); + +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); + +$ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); +ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); +$mi_foo->strengthen_slot_value( $i_foo, "moosen" ); +ok( !isweak($i_foo->{moosen}), '... white box test of weaken' ); + +undef $ref; + +is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "weak value can be strengthened" ); + +$mi_foo->deinitialize_slot( $i_foo, "moosen" ); + +ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot deinitialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); + +done_testing; diff --git a/t/cmop/instance_inline.t b/t/cmop/instance_inline.t new file mode 100644 index 0000000..07f2162 --- /dev/null +++ b/t/cmop/instance_inline.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP::Instance; + +my $C = 'Class::MOP::Instance'; + +{ + my $instance = '$self'; + my $slot_name = 'foo'; + my $value = '$value'; + my $class = '$class'; + + is($C->inline_create_instance($class), + 'bless {} => $class', + '... got the right code for create_instance'); + is($C->inline_get_slot_value($instance, $slot_name), + q[$self->{"foo"}], + '... got the right code for get_slot_value'); + + is($C->inline_set_slot_value($instance, $slot_name, $value), + q[$self->{"foo"} = $value], + '... got the right code for set_slot_value'); + + is($C->inline_initialize_slot($instance, $slot_name), + '', + '... got the right code for initialize_slot'); + + is($C->inline_is_slot_initialized($instance, $slot_name), + q[exists $self->{"foo"}], + '... got the right code for get_slot_value'); + + is($C->inline_weaken_slot_value($instance, $slot_name), + q[Scalar::Util::weaken( $self->{"foo"} )], + '... got the right code for weaken_slot_value'); + + is($C->inline_strengthen_slot_value($instance, $slot_name), + q[$self->{"foo"} = $self->{"foo"}], + '... got the right code for strengthen_slot_value'); + is($C->inline_rebless_instance_structure($instance, $class), + q[bless $self => $class], + '... got the right code for rebless_instance_structure'); +} + +done_testing; diff --git a/t/cmop/instance_metaclass_incompat.t b/t/cmop/instance_metaclass_incompat.t new file mode 100644 index 0000000..43188d0 --- /dev/null +++ b/t/cmop/instance_metaclass_incompat.t @@ -0,0 +1,68 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package Bar::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package FooBar::Meta::Instance; + use parent -norequire => 'Foo::Meta::Instance', 'Bar::Meta::Instance'; +} + +$@ = undef; +eval { + package Foo; + BEGIN { $INC{'Foo.pm'} = __FILE__ } + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + BEGIN { $INC{'Bar.pm'} = __FILE__ } + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + use parent -norequire => 'Foo'; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + use parent -norequire => 'Bar'; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + use parent -norequire => 'Foo'; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + use parent -norequire => 'Bar'; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/instance_metaclass_incompat_dyn.t b/t/cmop/instance_metaclass_incompat_dyn.t new file mode 100644 index 0000000..b648f44 --- /dev/null +++ b/t/cmop/instance_metaclass_incompat_dyn.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package Bar::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package FooBar::Meta::Instance; + use parent -norequire => 'Foo::Meta::Instance', 'Bar::Meta::Instance'; +} + +$@ = undef; +eval { + package Foo; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); + Foo::Foo->meta->superclasses('Foo'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); + Bar::Bar->meta->superclasses('Bar'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); + FooBar->meta->superclasses('Foo'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); + FooBar2->meta->superclasses('Bar'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/lib/ArrayBasedStorage.pm b/t/cmop/lib/ArrayBasedStorage.pm new file mode 100644 index 0000000..3d83a38 --- /dev/null +++ b/t/cmop/lib/ArrayBasedStorage.pm @@ -0,0 +1,132 @@ +package # hide the package from PAUSE + ArrayBasedStorage::Instance; + +use strict; +use warnings; +use Scalar::Util qw/refaddr/; + +use Carp 'confess'; + +our $VERSION = '0.01'; +my $unbound = \'empty-slot-value'; + +use parent 'Class::MOP::Instance'; + +sub new { + my ($class, $meta, @attrs) = @_; + my $self = $class->SUPER::new($meta, @attrs); + my $index = 0; + $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots }; + return $self; +} + +sub create_instance { + my $self = shift; + my $instance = bless [], $self->_class_name; + $self->initialize_all_slots($instance); + return $instance; +} + +sub clone_instance { + my ($self, $instance) = shift; + $self->bless_instance_structure([ @$instance ]); +} + +# operations on meta instance + +sub get_slot_index_map { (shift)->{'slot_index_map'} } + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub get_all_slots { + my $self = shift; + return sort $self->SUPER::get_all_slots; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; + return $value unless ref $value; + refaddr $value eq refaddr $unbound ? undef : $value; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + # NOTE: maybe use CLOS's *special-unbound-value* for this? + my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; + return 1 unless ref $value; + refaddr $value eq refaddr $unbound ? 0 : 1; +} + +sub is_dependent_on_superclasses { 1 } + +1; + +__END__ + +=pod + +=head1 NAME + +ArrayBasedStorage - An example of an Array based instance storage + +=head1 SYNOPSIS + + package Foo; + + use metaclass ( + ':instance_metaclass' => 'ArrayBasedStorage::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a proof of concept using the Instance sub-protocol +which uses ARRAY refs to store the instance data. + +This is very similar now to the InsideOutClass example, and +in fact, they both share the exact same test suite, with +the only difference being the Instance metaclass they use. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 SEE ALSO + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/AttributesWithHistory.pm b/t/cmop/lib/AttributesWithHistory.pm new file mode 100644 index 0000000..4978c99 --- /dev/null +++ b/t/cmop/lib/AttributesWithHistory.pm @@ -0,0 +1,135 @@ +package # hide the package from PAUSE + AttributesWithHistory; + +use strict; +use warnings; + +our $VERSION = '0.05'; + +use parent 'Class::MOP::Attribute'; + +# this is for an extra attribute constructor +# option, which is to be able to create a +# way for the class to access the history +AttributesWithHistory->meta->add_attribute('history_accessor' => ( + reader => 'history_accessor', + init_arg => 'history_accessor', + predicate => 'has_history_accessor', +)); + +# this is a place to store the actual +# history of the attribute +AttributesWithHistory->meta->add_attribute('_history' => ( + accessor => '_history', + default => sub { {} }, +)); + +sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' } + +AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { + my ($self) = @_; + # and now add the history accessor + $self->associated_class->add_method( + $self->_process_accessors('history_accessor' => $self->history_accessor()) + ) if $self->has_history_accessor(); +}); + +package # hide the package from PAUSE + AttributesWithHistory::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Method::Accessor'; + +# generate the methods + +sub _generate_history_accessor_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\}; + }}; +} + +sub _generate_accessor_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + if (scalar(\@_) == 2) { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + } + \$_[0]->{'$attr_name'}; + }}; +} + +sub _generate_writer_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + }}; +} + +1; + +=pod + +=head1 NAME + +AttributesWithHistory - An example attribute metaclass which keeps a history of changes + +=head1 SYSNOPSIS + + package Foo; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + +=head1 DESCRIPTION + +This is an example of an attribute metaclass which keeps a +record of all the values it has been assigned. It stores the +history as a field in the attribute meta-object, and will +autogenerate a means of accessing that history for the class +which these attributes are added too. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/BinaryTree.pm b/t/cmop/lib/BinaryTree.pm new file mode 100644 index 0000000..9a10e2c --- /dev/null +++ b/t/cmop/lib/BinaryTree.pm @@ -0,0 +1,142 @@ +package BinaryTree; + +use strict; +use warnings; +use Carp qw/confess/; + +use metaclass; + +our $VERSION = '0.02'; + +BinaryTree->meta->add_attribute('uid' => ( + reader => 'getUID', + writer => 'setUID', + default => sub { + my $instance = shift; + ("$instance" =~ /\((.*?)\)$/)[0]; + } +)); + +BinaryTree->meta->add_attribute('node' => ( + reader => 'getNodeValue', + writer => 'setNodeValue', + clearer => 'clearNodeValue', + init_arg => ':node' +)); + +BinaryTree->meta->add_attribute('parent' => ( + predicate => 'hasParent', + reader => 'getParent', + writer => 'setParent', + clearer => 'clearParent', +)); + +BinaryTree->meta->add_attribute('left' => ( + predicate => 'hasLeft', + clearer => 'clearLeft', + reader => 'getLeft', + writer => { + 'setLeft' => sub { + my ($self, $tree) = @_; + confess "undef left" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'left'} = $tree; + $self; + } + }, +)); + +BinaryTree->meta->add_attribute('right' => ( + predicate => 'hasRight', + clearer => 'clearRight', + reader => 'getRight', + writer => { + 'setRight' => sub { + my ($self, $tree) = @_; + confess "undef right" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'right'} = $tree; + $self; + } + } +)); + +sub new { + my $class = shift; + $class->meta->new_object(':node' => shift); +} + +sub removeLeft { + my ($self) = @_; + my $left = $self->getLeft(); + $left->clearParent; + $self->clearLeft; + return $left; +} + +sub removeRight { + my ($self) = @_; + my $right = $self->getRight; + $right->clearParent; + $self->clearRight; + return $right; +} + +sub isLeaf { + my ($self) = @_; + return (!$self->hasLeft && !$self->hasRight); +} + +sub isRoot { + my ($self) = @_; + return !$self->hasParent; +} + +sub traverse { + my ($self, $func) = @_; + $func->($self); + $self->getLeft->traverse($func) if $self->hasLeft; + $self->getRight->traverse($func) if $self->hasRight; +} + +sub mirror { + my ($self) = @_; + # swap left for right + if( $self->hasLeft && $self->hasRight) { + my $left = $self->getLeft; + my $right = $self->getRight; + $self->setLeft($right); + $self->setRight($left); + } elsif( $self->hasLeft && !$self->hasRight){ + my $left = $self->getLeft; + $self->clearLeft; + $self->setRight($left); + } elsif( !$self->hasLeft && $self->hasRight){ + my $right = $self->getRight; + $self->clearRight; + $self->setLeft($right); + } + + # and recurse + $self->getLeft->mirror if $self->hasLeft; + $self->getRight->mirror if $self->hasRight; + $self; +} + +sub size { + my ($self) = @_; + my $size = 1; + $size += $self->getLeft->size if $self->hasLeft; + $size += $self->getRight->size if $self->hasRight; + return $size; +} + +sub height { + my ($self) = @_; + my ($left_height, $right_height) = (0, 0); + $left_height = $self->getLeft->height() if $self->hasLeft(); + $right_height = $self->getRight->height() if $self->hasRight(); + return 1 + (($left_height > $right_height) ? $left_height : $right_height); +} + +1; diff --git a/t/cmop/lib/C3MethodDispatchOrder.pm b/t/cmop/lib/C3MethodDispatchOrder.pm new file mode 100644 index 0000000..c156133 --- /dev/null +++ b/t/cmop/lib/C3MethodDispatchOrder.pm @@ -0,0 +1,145 @@ +package # hide from PAUSE + C3MethodDispatchOrder; + +use strict; +use warnings; + +use Carp 'confess'; +use Algorithm::C3; + +our $VERSION = '0.03'; + +use parent 'Class::MOP::Class'; + +my $_find_method = sub { + my ($class, $method) = @_; + foreach my $super ($class->class_precedence_list) { + return $super->meta->get_method($method) + if $super->meta->has_method($method); + } +}; + +C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub { + my $cont = shift; + my $meta = $cont->(@_); + + # we need to look at $AUTOLOAD in the package where the coderef belongs + # if subname works, then it'll be where this AUTOLOAD method was installed + # otherwise, it'll be $C3MethodDispatchOrder::AUTOLOAD. get_code_info + # tells us where AUTOLOAD will look + my $autoload; + $autoload = sub { + my ($package) = Class::MOP::get_code_info($autoload); + my $label = ${ $package->meta->get_package_symbol('$AUTOLOAD') }; + my $method_name = (split /\:\:/ => $label)[-1]; + my $method = $_find_method->($_[0]->meta, $method_name); + (defined $method) || confess "Method ($method_name) not found"; + goto &$method; + }; + + $meta->add_method('AUTOLOAD' => $autoload) + unless $meta->has_method('AUTOLOAD'); + + $meta->add_method('can' => sub { + $_find_method->($_[0]->meta, $_[1]); + }) unless $meta->has_method('can'); + + return $meta; +}); + +sub superclasses { + my $self = shift; + + $self->add_package_symbol('@SUPERS' => []) + unless $self->has_package_symbol('@SUPERS'); + + if (@_) { + my @supers = @_; + @{$self->get_package_symbol('@SUPERS')} = @supers; + } + @{$self->get_package_symbol('@SUPERS')}; +} + +sub class_precedence_list { + my $self = shift; + return map { + $_->name; + } Algorithm::C3::merge($self, sub { + my $class = shift; + map { $_->meta } $class->superclasses; + }); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order + +=head1 SYNOPSIS + + # a classic diamond inheritence graph + # + # <A> + # / \ + # <B> <C> + # \ / + # <D> + + package A; + use metaclass 'C3MethodDispatchOrder'; + + sub hello { return "Hello from A" } + + package B; + use metaclass 'C3MethodDispatchOrder'; + B->meta->superclasses('A'); + + package C; + use metaclass 'C3MethodDispatchOrder'; + C->meta->superclasses('A'); + + sub hello { return "Hello from C" } + + package D; + use metaclass 'C3MethodDispatchOrder'; + D->meta->superclasses('B', 'C'); + + print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A + + # later in other code ... + + print D->hello; # print 'Hello from C' instead of the normal 'Hello from A' + +=head1 DESCRIPTION + +This is an example of how you could change the method dispatch order of a +class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces +the normal depth-first left-to-right perl dispatch order with the C3 method +dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more +information about this). + +This example could be used as a template for other method dispatch orders +as well, all that is required is to write a the C<class_precedence_list> method +which will return a linearized list of classes to dispatch along. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/ClassEncapsulatedAttributes.pm b/t/cmop/lib/ClassEncapsulatedAttributes.pm new file mode 100644 index 0000000..5fb3a24 --- /dev/null +++ b/t/cmop/lib/ClassEncapsulatedAttributes.pm @@ -0,0 +1,150 @@ +package # hide the package from PAUSE + ClassEncapsulatedAttributes; + +use strict; +use warnings; + +our $VERSION = '0.06'; + +use parent 'Class::MOP::Class'; + +sub initialize { + (shift)->SUPER::initialize(@_, + # use the custom attribute metaclass here + 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', + ); +} + +sub construct_instance { + my ($class, %params) = @_; + + my $meta_instance = $class->get_meta_instance; + my $instance = $meta_instance->create_instance(); + + # initialize *ALL* attributes, including masked ones (as opposed to applicable) + foreach my $current_class ($class->class_precedence_list()) { + my $meta = $current_class->meta; + foreach my $attr_name ($meta->get_attribute_list()) { + my $attr = $meta->get_attribute($attr_name); + $attr->initialize_instance_slot($meta_instance, $instance, \%params); + } + } + + return $instance; +} + +package # hide the package from PAUSE + ClassEncapsulatedAttributes::Attribute; + +use strict; +use warnings; + +our $VERSION = '0.04'; + +use parent 'Class::MOP::Attribute'; + +# alter the way parameters are specified +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + my $class = $self->associated_class; + my $val; + $val = $params->{$class->name}->{$init_arg} + if exists $params->{$class->name} && + exists ${$params->{$class->name}}{$init_arg}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if (!defined $val && $self->has_default) { + $val = $self->default($instance); + } + + # now add this to the instance structure + $meta_instance->set_slot_value($instance, $self->name, $val); +} + +sub name { + my $self = shift; + return ($self->associated_class->name . '::' . $self->SUPER::name) +} + +1; + +__END__ + +=pod + +=head1 NAME + +ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes + +=head1 SYNOPSIS + + package Foo; + + use metaclass 'ClassEncapsulatedAttributes'; + + Foo->meta->add_attribute('foo' => ( + accessor => 'Foo_foo', + default => 'init in FOO' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + our @ISA = ('Foo'); + + # duplicate the attribute name here + Bar->meta->add_attribute('foo' => ( + accessor => 'Bar_foo', + default => 'init in BAR' + )); + + # ... later in other code ... + + my $bar = Bar->new(); + prints $bar->Bar_foo(); # init in BAR + prints $bar->Foo_foo(); # init in FOO + + # and ... + + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + + prints $bar->Bar_foo(); # Foo::foo + prints $bar->Foo_foo(); # Bar::foo + +=head1 DESCRIPTION + +This is an example metaclass which encapsulates a class's +attributes on a per-class basis. This means that there is no +possibility of name clashes with inherited attributes. This +is similar to how C++ handles its data members. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Yuval "nothingmuch" Kogman for the idea for this example. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/InsideOutClass.pm b/t/cmop/lib/InsideOutClass.pm new file mode 100644 index 0000000..94ec0c5 --- /dev/null +++ b/t/cmop/lib/InsideOutClass.pm @@ -0,0 +1,194 @@ +package # hide the package from PAUSE + InsideOutClass::Attribute; + +use strict; +use warnings; + +our $VERSION = '0.02'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Attribute'; + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->init_arg; + # try to fetch the init arg from the %params ... + my $val; + $val = $params->{$init_arg} if exists $params->{$init_arg}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if (!defined $val && defined $self->default) { + $val = $self->default($instance); + } + my $_meta_instance = $self->associated_class->get_meta_instance; + $_meta_instance->initialize_slot($instance, $self->name); + $_meta_instance->set_slot_value($instance, $self->name, $val); +} + +sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } + +package # hide the package from PAUSE + InsideOutClass::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Method::Accessor'; + +## Method generation helpers + +sub _generate_accessor_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + my $meta_instance = $meta_class->get_meta_instance; + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +sub _generate_reader_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name); + }; +} + +sub _generate_writer_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + $meta_class->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[1]); + }; +} + +sub _generate_predicate_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + defined $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; + }; +} + +package # hide the package from PAUSE + InsideOutClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Instance'; + +sub create_instance { + my ($self, $class) = @_; + bless \(my $instance), $self->_class_name; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) + unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; +} + +1; + +__END__ + +=pod + +=head1 NAME + +InsideOutClass - A set of example metaclasses which implement the Inside-Out technique + +=head1 SYNOPSIS + + package Foo; + + use metaclass ( + ':attribute_metaclass' => 'InsideOutClass::Attribute', + ':instance_metaclass' => 'InsideOutClass::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a set of example metaclasses which implement the Inside-Out +class technique. What follows is a brief explaination of the code +found in this module. + +We must create a subclass of B<Class::MOP::Instance> and override +the slot operations. This requires +overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and +C<initialize_slot>, as well as their inline counterparts. Additionally we +overload C<add_slot> in order to initialize the global hash containing the +actual slot values. + +And that is pretty much all. Of course I am ignoring need for +inside-out objects to be C<DESTROY>-ed, and some other details as +well (threading, etc), but this is an example. A real implementation is left as +an exercise to the reader. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/InstanceCountingClass.pm b/t/cmop/lib/InstanceCountingClass.pm new file mode 100644 index 0000000..35053fe --- /dev/null +++ b/t/cmop/lib/InstanceCountingClass.pm @@ -0,0 +1,72 @@ +package # hide the package from PAUSE + InstanceCountingClass; + +use strict; +use warnings; + +our $VERSION = '0.03'; + +use parent 'Class::MOP::Class'; + +InstanceCountingClass->meta->add_attribute('count' => ( + reader => 'get_count', + default => 0 +)); + +InstanceCountingClass->meta->add_before_method_modifier('_construct_instance' => sub { + my ($class) = @_; + $class->{'count'}++; +}); + +1; + +__END__ + +=pod + +=head1 NAME + +InstanceCountingClass - An example metaclass which counts instances + +=head1 SYNOPSIS + + package Foo; + + use metaclass 'InstanceCountingClass'; + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # ... meanwhile, somewhere in the code + + my $foo = Foo->new(); + print Foo->meta->get_count(); # prints 1 + + my $foo2 = Foo->new(); + print Foo->meta->get_count(); # prints 2 + + # ... etc etc etc + +=head1 DESCRIPTION + +This is a classic example of a metaclass which keeps a count of each +instance which is created. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/LazyClass.pm b/t/cmop/lib/LazyClass.pm new file mode 100644 index 0000000..1a2dc13 --- /dev/null +++ b/t/cmop/lib/LazyClass.pm @@ -0,0 +1,162 @@ +package # hide the package from PAUSE + LazyClass::Attribute; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.05'; + +use parent 'Class::MOP::Attribute'; + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $self->init_arg(); + + if ( exists $params->{$init_arg} ) { + my $val = $params->{$init_arg}; + $meta_instance->set_slot_value($instance, $self->name, $val); + } +} + +sub accessor_metaclass { 'LazyClass::Method::Accessor' } + +package # hide the package from PAUSE + LazyClass::Method::Accessor; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Method::Accessor'; + +sub _generate_accessor_method { + my $attr = (shift)->associated_attribute; + + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->get_meta_instance; + + sub { + if (scalar(@_) == 2) { + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); + } + else { + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value($_[0], $attr_name, $value); + } + + $meta_instance->get_slot_value($_[0], $attr_name); + } + }; +} + +sub _generate_reader_method { + my $attr = (shift)->associated_attribute; + + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->get_meta_instance; + + sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value($_[0], $attr_name, $value); + } + + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +package # hide the package from PAUSE + LazyClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Instance'; + +sub initialize_all_slots {} + +1; + +__END__ + +=pod + +=head1 NAME + +LazyClass - An example metaclass with lazy initialization + +=head1 SYNOPSIS + + package BinaryTree; + + use metaclass ( + ':attribute_metaclass' => 'LazyClass::Attribute', + ':instance_metaclass' => 'LazyClass::Instance', + ); + + BinaryTree->meta->add_attribute('node' => ( + accessor => 'node', + init_arg => ':node' + )); + + BinaryTree->meta->add_attribute('left' => ( + reader => 'left', + default => sub { BinaryTree->new() } + )); + + BinaryTree->meta->add_attribute('right' => ( + reader => 'right', + default => sub { BinaryTree->new() } + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # ... later in code + + my $btree = BinaryTree->new(); + # ... $btree is an empty hash, no keys are initialized yet + +=head1 DESCRIPTION + +This is an example metclass in which all attributes are created +lazily. This means that no entries are made in the instance HASH +until the last possible moment. + +The example above of a binary tree is a good use for such a +metaclass because it allows the class to be space efficient +without complicating the programing of it. This would also be +ideal for a class which has a large amount of attributes, +several of which are optional. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/MyMetaClass.pm b/t/cmop/lib/MyMetaClass.pm new file mode 100644 index 0000000..ade02e5 --- /dev/null +++ b/t/cmop/lib/MyMetaClass.pm @@ -0,0 +1,14 @@ +package MyMetaClass; + +use strict; +use warnings; + +use parent 'Class::MOP::Class'; + +sub mymetaclass_attributes{ + my $self = shift; + return grep { $_->isa("MyMetaClass::Attribute") } + $self->get_all_attributes; +} + +1; diff --git a/t/cmop/lib/MyMetaClass/Attribute.pm b/t/cmop/lib/MyMetaClass/Attribute.pm new file mode 100644 index 0000000..c187e9a --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Attribute.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Attribute; + +use strict; +use warnings; + +use parent 'Class::MOP::Attribute'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Instance.pm b/t/cmop/lib/MyMetaClass/Instance.pm new file mode 100644 index 0000000..5383c4a --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Instance.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Instance; + +use strict; +use warnings; + +use parent 'Class::MOP::Instance'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Method.pm b/t/cmop/lib/MyMetaClass/Method.pm new file mode 100644 index 0000000..072d49d --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Method.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Method; + +use strict; +use warnings; + +use parent 'Class::MOP::Method'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Random.pm b/t/cmop/lib/MyMetaClass/Random.pm new file mode 100644 index 0000000..1c79b7b --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Random.pm @@ -0,0 +1,6 @@ +package MyMetaClass::Random; + +use strict; +use warnings; + +1; diff --git a/t/cmop/lib/Perl6Attribute.pm b/t/cmop/lib/Perl6Attribute.pm new file mode 100644 index 0000000..420ef30 --- /dev/null +++ b/t/cmop/lib/Perl6Attribute.pm @@ -0,0 +1,82 @@ +package # hide the package from PAUSE + Perl6Attribute; + +use strict; +use warnings; + +our $VERSION = '0.02'; + +use parent 'Class::MOP::Attribute'; + +Perl6Attribute->meta->add_around_method_modifier('new' => sub { + my $cont = shift; + my ($class, $attribute_name, %options) = @_; + + # extract the sigil and accessor name + my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/); + + # pass the accessor name + $options{accessor} = $accessor_name; + + # create a default value based on the sigil + $options{default} = sub { [] } if ($sigil eq '@'); + $options{default} = sub { {} } if ($sigil eq '%'); + + $cont->($class, $attribute_name, %options); +}); + +1; + +__END__ + +=pod + +=head1 NAME + +Perl6Attribute - An example attribute metaclass for Perl 6 style attributes + +=head1 SYNOPSIS + + package Foo; + + Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); + Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); + Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + +=head1 DESCRIPTION + +This is an attribute metaclass which implements Perl 6 style +attributes, including the auto-generating accessors. + +This code is very simple, we only need to subclass +C<Class::MOP::Attribute> and override C<&new>. Then we just +pre-process the attribute name, and create the accessor name +and default value based on it. + +More advanced features like the C<handles> trait (see +L<Perl6::Bible/A12>) can be accomplished as well doing the +same pre-processing approach. This is left as an exercise to +the reader though (if you do it, please send me a patch +though, and will update this). + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/SyntaxError.pm b/t/cmop/lib/SyntaxError.pm new file mode 100644 index 0000000..ab41f14 --- /dev/null +++ b/t/cmop/lib/SyntaxError.pm @@ -0,0 +1,9 @@ +package SyntaxError; +use strict; +use warnings; + +# this syntax error is intentional! + + { + +1; diff --git a/t/cmop/load.t b/t/cmop/load.t new file mode 100644 index 0000000..72f9bb7 --- /dev/null +++ b/t/cmop/load.t @@ -0,0 +1,176 @@ +use strict; +use warnings; + +# for instance, App::ForkProve +my $preloaded; +BEGIN { $preloaded = exists $INC{'Class/MOP.pm'} } + +use Test::More; + +use Class::Load qw(is_class_loaded); + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Mixin'); + use_ok('Class::MOP::Mixin::AttributeCore'); + use_ok('Class::MOP::Mixin::HasAttributes'); + use_ok('Class::MOP::Mixin::HasMethods'); + use_ok('Class::MOP::Mixin::HasOverloads'); + use_ok('Class::MOP::Package'); + use_ok('Class::MOP::Module'); + use_ok('Class::MOP::Class'); + use_ok('Class::MOP::Class::Immutable::Trait'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method::Wrapped'); + use_ok('Class::MOP::Method::Inlined'); + use_ok('Class::MOP::Method::Generated'); + use_ok('Class::MOP::Method::Accessor'); + use_ok('Class::MOP::Method::Constructor'); + use_ok('Class::MOP::Method::Meta'); + use_ok('Class::MOP::Instance'); + use_ok('Class::MOP::Object'); + use_ok('Class::MOP::Overload'); +} + +# make sure we are tracking metaclasses correctly + +my %METAS = ( + 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, + 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta, + 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, + 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta, + 'Class::MOP::Mixin' => Class::MOP::Mixin->meta, + 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta, + 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta, + 'Class::MOP::Mixin::HasMethods' => Class::MOP::Mixin::HasMethods->meta, + 'Class::MOP::Mixin::HasOverloads' => Class::MOP::Mixin::HasOverloads->meta, + 'Class::MOP::Package' => Class::MOP::Package->meta, + 'Class::MOP::Module' => Class::MOP::Module->meta, + 'Class::MOP::Class' => Class::MOP::Class->meta, + 'Class::MOP::Method' => Class::MOP::Method->meta, + 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, + 'Class::MOP::Instance' => Class::MOP::Instance->meta, + 'Class::MOP::Object' => Class::MOP::Object->meta, + 'Class::MOP::Overload' => Class::MOP::Overload->meta, + 'Class::MOP::Class::Immutable::Trait' => Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), + 'Class::MOP::Class::Immutable::Class::MOP::Class' => Class::MOP::Class::Immutable::Class::MOP::Class->meta, + 'UNIVERSAL' => Class::MOP::class_of('UNIVERSAL'), +); + +ok( is_class_loaded($_), '... ' . $_ . ' is loaded' ) + for sort keys %METAS; + +# The trait shouldn't be made immutable, it doesn't actually do anything, and +# it doesn't even matter because it's not a class that will be +# instantiated. Making UNIVERSAL immutable just seems like a bad idea. +my %expect_mutable = map { $_ => 1 } qw( Class::MOP::Class::Immutable::Trait UNIVERSAL ); + +for my $meta (values %METAS) { + if ( $expect_mutable{$meta->name} ) { + ok( $meta->is_mutable(), '... ' . $meta->name . ' is mutable' ); + } + else { + ok( $meta->is_immutable(), '... ' . $meta->name . ' is immutable' ); + } +} + +SKIP: { + skip "this list may be incorrect if we preloaded things", 3 if $preloaded; + is_deeply( + {Class::MOP::get_all_metaclasses}, + \%METAS, + '... got all the metaclasses' + ); + + is_deeply( + [ + sort { $a->name cmp $b->name } + Class::MOP::get_all_metaclass_instances + ], + [ + Class::MOP::Attribute->meta, + Class::MOP::Class->meta, + Class::MOP::Class::Immutable::Class::MOP::Class->meta, + Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), + Class::MOP::Instance->meta, + Class::MOP::Method->meta, + Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Constructor->meta, + Class::MOP::Method::Generated->meta, + Class::MOP::Method::Inlined->meta, + Class::MOP::Method::Meta->meta, + Class::MOP::Method::Wrapped->meta, + Class::MOP::Mixin->meta, + Class::MOP::Mixin::AttributeCore->meta, + Class::MOP::Mixin::HasAttributes->meta, + Class::MOP::Mixin::HasMethods->meta, + Class::MOP::Mixin::HasOverloads->meta, + Class::MOP::Module->meta, + Class::MOP::Object->meta, + Class::MOP::Overload->meta, + Class::MOP::Package->meta, + Class::MOP::class_of('UNIVERSAL'), + ], + '... got all the metaclass instances' + ); + + is_deeply( + [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], + [ + sort qw/ + Class::MOP::Attribute + Class::MOP::Class + Class::MOP::Class::Immutable::Class::MOP::Class + Class::MOP::Class::Immutable::Trait + Class::MOP::Mixin + Class::MOP::Mixin::AttributeCore + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin::HasOverloads + Class::MOP::Instance + Class::MOP::Method + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor + Class::MOP::Method::Generated + Class::MOP::Method::Inlined + Class::MOP::Method::Wrapped + Class::MOP::Method::Meta + Class::MOP::Module + Class::MOP::Object + Class::MOP::Overload + Class::MOP::Package + UNIVERSAL + /, + ], + '... got all the metaclass names' + ); +} + +# testing the meta-circularity of the system + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta->meta, Class::MOP::Class->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta->meta == Class::MOP::Class->meta->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta->meta' +); + +isa_ok(Class::MOP::Class->meta, 'Class::MOP::Class'); + +done_testing; diff --git a/t/cmop/magic.t b/t/cmop/magic.t new file mode 100644 index 0000000..bfb9dba --- /dev/null +++ b/t/cmop/magic.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +# Testing magical scalars (using tied scalar) +# Note that XSUBs do not handle magical scalars automatically. + +use Test::More; +use Test::Fatal; + +use Class::Load qw( is_class_loaded load_class ); +use Class::MOP; + +use Tie::Scalar; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + Foo->meta->add_attribute('baz' => + accessor => 'baz', + ); + + Foo->meta->make_immutable(); +} + +{ + tie my $foo, 'Tie::StdScalar', Foo->new(bar => 100, baz => 200); + + is $foo->get_bar, 100, 'reader with tied self'; + is $foo->baz, 200, 'accessor/r with tied self'; + + $foo->set_bar(300); + $foo->baz(400); + + is $foo->get_bar, 300, 'writer with tied self'; + is $foo->baz, 400, 'accessor/w with tied self'; +} + +{ + my $foo = Foo->new(); + + tie my $value, 'Tie::StdScalar', 42; + + $foo->set_bar($value); + $foo->baz($value); + + is $foo->get_bar, 42, 'reader/writer with tied value'; + is $foo->baz, 42, 'accessor with tied value'; +} + +{ + my $x = tie my $value, 'Tie::StdScalar', 'Class::MOP'; + + is( exception { load_class($value) }, undef, 'load_class(tied scalar)' ); + + $value = undef; + $x->STORE('Class::MOP'); # reset + + is( exception { + ok is_class_loaded($value); + }, undef, 'is_class_loaded(tied scalar)' ); + + $value = undef; + $x->STORE(\&Class::MOP::get_code_info); # reset + + is( exception { + is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)'; + }, undef ); +} + +done_testing; diff --git a/t/cmop/make_mutable.t b/t/cmop/make_mutable.t new file mode 100644 index 0000000..cf30738 --- /dev/null +++ b/t/cmop/make_mutable.t @@ -0,0 +1,220 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util; + +use Class::MOP; + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Baz metaclass'); + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + # Since this has no default it won't be present yet, but it will + # be after the class is made immutable. + + is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable' ); + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->make_immutable, '... make immutable returns true'); + ok($meta->get_method('new'), '... inlined constructor created'); + ok($meta->has_method('new'), '... inlined constructor created for sure'); + is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it'); + + is( exception { $meta->make_mutable; }, undef, '... changed Baz to be mutable' ); + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok(!$meta->get_method('new'), '... inlined constructor created'); + ok(!$meta->has_method('new'), '... inlined constructor removed for sure'); + + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + + isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); + + $meta->add_method('xyz', sub{'xxx'}); + is( Baz->xyz, 'xxx', '... method xyz works'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok(Baz->can('fickle'), '... Baz can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + $meta->add_package_symbol('$ref', $reef); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); + + is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable again' ); + ok($meta->get_method('new'), '... inlined constructor recreated'); +} + +{ + my $meta = Baz->meta; + + is( exception { $meta->make_immutable() }, undef, 'Changed Baz to be immutable' ); + is( exception { $meta->make_mutable() }, undef, '... changed Baz to be mutable' ); + is( exception { $meta->make_immutable() }, undef, '... changed Baz to be immutable' ); + + isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); + + isnt( exception { + $meta->add_attribute('fickle', accessor => 'fickle') + }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); + + my $reef = \ 'reef'; + isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +} + +{ + + ok(Baz->meta->is_immutable, 'Superclass is immutable'); + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_methods; + ok($meta->is_anon_class, 'We have an anon metaclass'); + ok($meta->is_mutable, '... our anon class is mutable'); + ok(!$meta->is_immutable, '... our anon class is not immutable'); + + is( exception {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + }, undef, '... changed class to be immutable' ); + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->make_immutable, '... make immutable returns true'); + + is( exception { $meta->make_mutable }, undef, '... changed Baz to be mutable' ); + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok($meta->is_anon_class, '... still marked as an anon class'); + my $instance = $meta->new_object; + + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + my @new_meths = sort { $a->name cmp $b->name } + $meta->get_all_methods; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); + + isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); + + $meta->add_method('xyz', sub{'xxx'}); + is( $instance->xyz , 'xxx', '... method xyz works'); + ok( $meta->remove_method('xyz'), '... removed method'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok($instance->can('fickle'), '... instance can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + $meta->add_package_symbol('$ref', $reef); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +}; + + +#rerun the same tests on an anon class.. just cause we can. +{ + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + + is( exception {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + }, undef, '... changed class to be immutable' ); + is( exception { $meta->make_mutable() }, undef, '... changed class to be mutable' ); + is( exception {$meta->make_immutable }, undef, '... changed class to be immutable' ); + + isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); + + isnt( exception { + $meta->add_attribute('fickle', accessor => 'fickle') + }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); + + my $reef = \ 'reef'; + isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +} + +{ + Foo->meta->make_immutable; + Bar->meta->make_immutable; + Bar->meta->make_mutable; +} + +done_testing; diff --git a/t/cmop/meta_method.t b/t/cmop/meta_method.t new file mode 100644 index 0000000..de65543 --- /dev/null +++ b/t/cmop/meta_method.t @@ -0,0 +1,66 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Class::MOP; + +{ + can_ok('Class::MOP::Class', 'meta'); + isa_ok(Class::MOP::Class->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); + + { + package Baz; + use metaclass; + } + can_ok('Baz', 'meta'); + isa_ok(Baz->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); + + my $meta = Class::MOP::Class->create('Quux'); + can_ok('Quux', 'meta'); + isa_ok(Quux->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); +} + +{ + { + package Blarg; + use metaclass meta_name => 'blarg'; + } + ok(!Blarg->can('meta')); + can_ok('Blarg', 'blarg'); + isa_ok(Blarg->blarg->find_method_by_name('blarg'), + 'Class::MOP::Method::Meta'); + + my $meta = Class::MOP::Class->create('Blorg', meta_name => 'blorg'); + ok(!Blorg->can('meta')); + can_ok('Blorg', 'blorg'); + isa_ok(Blorg->blorg->find_method_by_name('blorg'), + 'Class::MOP::Method::Meta'); +} + +{ + { + package Foo; + use metaclass meta_name => undef; + } + + my $meta = Class::MOP::class_of('Foo'); + ok(!$meta->has_method('meta'), "no meta method was installed"); + $meta->add_method(meta => sub { die 'META' }); + is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); + is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); + is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); +} + +{ + my $meta = Class::MOP::Class->create('Bar', meta_name => undef); + ok(!$meta->has_method('meta'), "no meta method was installed"); + $meta->add_method(meta => sub { die 'META' }); + is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); + is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); + is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); +} + +done_testing; diff --git a/t/cmop/meta_package.t b/t/cmop/meta_package.t new file mode 100644 index 0000000..8e7f76e --- /dev/null +++ b/t/cmop/meta_package.t @@ -0,0 +1,280 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Package; + + +isnt( exception { Class::MOP::Package->get_all_package_symbols }, undef, q{... can't call get_all_package_symbols() as a class method} ); +isnt( exception { Class::MOP::Package->name }, undef, q{... can't call name() as a class method} ); + +{ + package Foo; + + use constant SOME_CONSTANT => 1; + + sub meta { Class::MOP::Package->initialize('Foo') } +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +is( exception { + Foo->meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully' ); + +# ... scalar should NOT be created here + +ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('$baz' => 10); +}, undef, '... created $Foo::baz successfully' ); + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); +}, undef, '... created &Foo::funk successfully' ); + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is( exception { + Foo->meta->add_package_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = Foo->meta->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is( exception { + Foo->meta->remove_package_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +# get_all_package_symbols + +{ + my $syms = Foo->meta->get_all_package_symbols; + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols ], + '... the fetched symbols are the same as the listed ones' + ); +} + +{ + my $syms = Foo->meta->get_all_package_symbols('CODE'); + + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols('CODE') ], + '... the fetched symbols are the same as the listed ones' + ); + + foreach my $symbol (keys %{ $syms }) { + is($syms->{$symbol}, Foo->meta->get_package_symbol('&' . $symbol), '... got the right symbol'); + } +} + +{ + Foo->meta->add_package_symbol('%zork'); + + my $syms = Foo->meta->get_all_package_symbols('HASH'); + + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols('HASH') ], + '... the fetched symbols are the same as the listed ones' + ); + + foreach my $symbol (keys %{ $syms }) { + is($syms->{$symbol}, Foo->meta->get_package_symbol('%' . $symbol), '... got the right symbol'); + } + + no warnings 'once'; + is_deeply( + $syms, + { zork => \%Foo::zork }, + "got the right ones", + ); +} + +done_testing; diff --git a/t/cmop/meta_package_extension.t b/t/cmop/meta_package_extension.t new file mode 100644 index 0000000..4754275 --- /dev/null +++ b/t/cmop/meta_package_extension.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package My::Package::Stash; + use strict; + use warnings; + + use parent 'Package::Stash'; + + use metaclass; + + use Symbol 'gensym'; + + __PACKAGE__->meta->add_attribute( + 'namespace' => ( + reader => 'namespace', + default => sub { {} } + ) + ); + + sub new { + my $class = shift; + $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_)); + } + + sub add_symbol { + my ($self, $variable, $initial_value) = @_; + + (my $name = $variable) =~ s/^[\$\@\%\&]//; + + my $glob = gensym(); + *{$glob} = $initial_value if defined $initial_value; + $self->namespace->{$name} = *{$glob}; + } +} + +{ + package My::Meta::Package; + + use strict; + use warnings; + + use parent 'Class::MOP::Package'; + + sub _package_stash { + $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name); + } +} + +# No actually package Foo exists :) +my $meta = My::Meta::Package->initialize('Foo'); + +isa_ok($meta, 'My::Meta::Package'); +isa_ok($meta, 'Class::MOP::Package'); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$meta->has_package_symbol('%foo'), '... the meta agrees'); + +is( exception { + $meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... the %foo symbol is created succcessfully' ); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); +ok($meta->has_package_symbol('%foo'), '... the meta agrees'); + +my $foo = $meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); + +ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); + +is( exception { + $meta->add_package_symbol('%baz'); +}, undef, '... created %Foo::baz successfully' ); + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); + +done_testing; diff --git a/t/cmop/metaclass.t b/t/cmop/metaclass.t new file mode 100644 index 0000000..6bc5b64 --- /dev/null +++ b/t/cmop/metaclass.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +{ + package FooMeta; + use parent 'Class::MOP::Class'; + + package Foo; + use metaclass 'FooMeta'; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'FooMeta'); +isa_ok(Foo->meta, 'Class::MOP::Class'); + +{ + package BarMeta; + use parent 'Class::MOP::Class'; + + package BarMeta::Attribute; + use parent 'Class::MOP::Attribute'; + + package BarMeta::Method; + use parent 'Class::MOP::Method'; + + package Bar; + use metaclass 'BarMeta' => ( + 'attribute_metaclass' => 'BarMeta::Attribute', + 'method_metaclass' => 'BarMeta::Method', + ); +} + +can_ok('Bar', 'meta'); +isa_ok(Bar->meta, 'BarMeta'); +isa_ok(Bar->meta, 'Class::MOP::Class'); + +is(Bar->meta->attribute_metaclass, 'BarMeta::Attribute', '... got the right attribute metaobject'); +is(Bar->meta->method_metaclass, 'BarMeta::Method', '... got the right method metaobject'); + +{ + package Baz; + use metaclass; +} + +can_ok('Baz', 'meta'); +isa_ok(Baz->meta, 'Class::MOP::Class'); + +eval { + package Boom; + metaclass->import('Foo'); +}; +ok($@, '... metaclasses must be subclass of Class::MOP::Class'); + +done_testing; diff --git a/t/cmop/metaclass_incompatibility.t b/t/cmop/metaclass_incompatibility.t new file mode 100644 index 0000000..9991a18 --- /dev/null +++ b/t/cmop/metaclass_incompatibility.t @@ -0,0 +1,264 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use metaclass; + +my %metaclass_attrs; +BEGIN { + %metaclass_attrs = ( + 'Instance' => 'instance_metaclass', + 'Attribute' => 'attribute_metaclass', + 'Method' => 'method_metaclass', + 'Method::Wrapped' => 'wrapped_method_metaclass', + 'Method::Constructor' => 'constructor_class', + ); + + # meta classes + for my $suffix ('Class', keys %metaclass_attrs) { + Class::MOP::Class->create( + "Foo::Meta::$suffix", + superclasses => ["Class::MOP::$suffix"] + ); + Class::MOP::Class->create( + "Bar::Meta::$suffix", + superclasses => ["Class::MOP::$suffix"] + ); + Class::MOP::Class->create( + "FooBar::Meta::$suffix", + superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"] + ); + } +} + +# checking... + +is( exception { + Foo::Meta::Class->create('Foo') +}, undef, '... Foo.meta => Foo::Meta::Class is compatible' ); +is( exception { + Bar::Meta::Class->create('Bar') +}, undef, '... Bar.meta => Bar::Meta::Class is compatible' ); + +like( exception { + Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo']) +}, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' ); +like( exception { + Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar']) +}, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' ); + +is( exception { + FooBar::Meta::Class->create('FooBar', superclasses => ['Foo']) +}, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' ); +is( exception { + FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar']) +}, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' ); + +Foo::Meta::Class->create( + 'Foo::All', + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, +); + +like( exception { + Bar::Meta::Class->create( + 'Foo::All::Sub::Class', + superclasses => ['Foo::All'], + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, + ) +}, qr/compatible/, 'incompatible Class metaclass' ); +for my $suffix (keys %metaclass_attrs) { + like( exception { + Foo::Meta::Class->create( + "Foo::All::Sub::$suffix", + superclasses => ['Foo::All'], + (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), + $metaclass_attrs{$suffix} => "Bar::Meta::$suffix", + ) + }, qr/compatible/, "incompatible $suffix metaclass" ); +} + +# fixing... + +is( exception { + Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo']) +}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); +isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class'); +is( exception { + Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar']) +}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); +isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class'); + +is( exception { + Class::MOP::Class->create( + 'Foo::All::Sub::CMOP::Class', + superclasses => ['Foo::All'], + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, + ) +}, undef, 'metaclass fixing works with other non-default metaclasses' ); +isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class'); + +for my $suffix (keys %metaclass_attrs) { + is( exception { + Foo::Meta::Class->create( + "Foo::All::Sub::CMOP::$suffix", + superclasses => ['Foo::All'], + (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), + $metaclass_attrs{$suffix} => "Class::MOP::$suffix", + ) + }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" ); + for my $suffix2 (keys %metaclass_attrs) { + my $method = $metaclass_attrs{$suffix2}; + isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2"); + } +} + +# initializing... + +{ + package Foo::NoMeta; +} + +Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']); +ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); +isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class'); +isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class'); + +{ + package Foo::NoMeta2; +} +Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']); +ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); +isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class'); +isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class'); + + +BEGIN { + Foo::Meta::Class->create('Foo::WithMeta'); +} +{ + package Foo::WithMeta::Sub; + use parent -norequire => 'Foo::WithMeta'; +} +Class::MOP::Class->create( + 'Foo::WithMeta::Sub::Sub', + superclasses => ['Foo::WithMeta::Sub'] +); + +isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class'); + +BEGIN { + Foo::Meta::Class->create('Foo::WithMeta2'); +} +{ + package Foo::WithMeta2::Sub; + use parent -norequire => 'Foo::WithMeta2'; +} +{ + package Foo::WithMeta2::Sub::Sub; + use parent -norequire => 'Foo::WithMeta2::Sub'; +} +Class::MOP::Class->create( + 'Foo::WithMeta2::Sub::Sub::Sub', + superclasses => ['Foo::WithMeta2::Sub::Sub'] +); + +isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class'); + +Class::MOP::Class->create( + 'Foo::Reverse::Sub::Sub', + superclasses => ['Foo::Reverse::Sub'], +); +eval "package Foo::Reverse::Sub; use parent -norequire => 'Foo::Reverse';"; +Foo::Meta::Class->create( + 'Foo::Reverse', +); +isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class'); +{ local $TODO = 'No idea how to handle case where child class is created before parent'; +isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class'); +} + +# unsafe fixing... + +{ + Class::MOP::Class->create( + 'Foo::Unsafe', + attribute_metaclass => 'Foo::Meta::Attribute', + ); + my $meta = Class::MOP::Class->create( + 'Foo::Unsafe::Sub', + ); + $meta->add_attribute(foo => reader => 'foo'); + like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" ); +} + +# immutability... + +{ + my $foometa = Foo::Meta::Class->create( + 'Foo::Immutable', + ); + $foometa->make_immutable; + my $barmeta = Class::MOP::Class->create( + 'Bar::Mutable', + ); + my $bazmeta = Class::MOP::Class->create( + 'Baz::Mutable', + ); + $bazmeta->superclasses($foometa->name); + is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" ); + ok(!$bazmeta->is_immutable, + "immutable superclass doesn't make this class immutable"); + is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" ); +} + +# nonexistent metaclasses + +Class::MOP::Class->create( + 'Weird::Meta::Method::Destructor', + superclasses => ['Class::MOP::Method'], +); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class', + destructor_class => 'Weird::Meta::Method::Destructor', + ); +}, undef, "defined metaclass in child with defined metaclass in parent is fine" ); + +is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class::Sub', + superclasses => ['Weird::Class'], + destructor_class => undef, + ); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class::Sub2', + destructor_class => undef, + ); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is( exception { + Weird::Class::Sub2->meta->superclasses('Weird::Class'); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +done_testing; diff --git a/t/cmop/metaclass_incompatibility_dyn.t b/t/cmop/metaclass_incompatibility_dyn.t new file mode 100644 index 0000000..dccec28 --- /dev/null +++ b/t/cmop/metaclass_incompatibility_dyn.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta; + use parent 'Class::MOP::Class'; + + package Bar::Meta; + use parent 'Class::MOP::Class'; + + package FooBar::Meta; + use parent -norequire => 'Foo::Meta', 'Bar::Meta'; +} + +$@ = undef; +eval { + package Foo; + metaclass->import('Foo::Meta'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + metaclass->import('Bar::Meta'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + metaclass->import('Bar::Meta'); + Foo::Foo->meta->superclasses('Foo'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + metaclass->import('Foo::Meta'); + Bar::Bar->meta->superclasses('Bar'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + metaclass->import('FooBar::Meta'); + FooBar->meta->superclasses('Foo'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + metaclass->import('FooBar::Meta'); + FooBar2->meta->superclasses('Bar'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/metaclass_inheritance.t b/t/cmop/metaclass_inheritance.t new file mode 100644 index 0000000..0cc2a5c --- /dev/null +++ b/t/cmop/metaclass_inheritance.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +=pod + +Test that a default set up will cause metaclasses to inherit +the same metaclass type, but produce different metaclasses. + +=cut + +{ + package Foo; + use metaclass; + + package Bar; + use parent -norequire => 'Foo'; + + package Baz; + use parent -norequire => 'Bar'; +} + +my $foo_meta = Foo->meta; +isa_ok($foo_meta, 'Class::MOP::Class'); + +is($foo_meta->name, 'Foo', '... foo_meta->name == Foo'); + +my $bar_meta = Bar->meta; +isa_ok($bar_meta, 'Class::MOP::Class'); + +is($bar_meta->name, 'Bar', '... bar_meta->name == Bar'); +isnt($bar_meta, $foo_meta, '... Bar->meta != Foo->meta'); + +my $baz_meta = Baz->meta; +isa_ok($baz_meta, 'Class::MOP::Class'); + +is($baz_meta->name, 'Baz', '... baz_meta->name == Baz'); +isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta'); +isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta'); + +done_testing; diff --git a/t/cmop/metaclass_loads_classes.t b/t/cmop/metaclass_loads_classes.t new file mode 100644 index 0000000..9c0fa01 --- /dev/null +++ b/t/cmop/metaclass_loads_classes.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; + +use Class::Load qw(is_class_loaded); + +use lib 't/cmop/lib'; + +{ + package Foo; + + use strict; + use warnings; + + use metaclass 'MyMetaClass' => ( + 'attribute_metaclass' => 'MyMetaClass::Attribute', + 'instance_metaclass' => 'MyMetaClass::Instance', + 'method_metaclass' => 'MyMetaClass::Method', + 'random_metaclass' => 'MyMetaClass::Random', + ); +} + +my $meta = Foo->meta; + +isa_ok($meta, 'MyMetaClass', '... Correct metaclass'); +ok(is_class_loaded('MyMetaClass'), '... metaclass loaded'); + +is($meta->attribute_metaclass, 'MyMetaClass::Attribute', '... Correct attribute metaclass'); +ok(is_class_loaded('MyMetaClass::Attribute'), '... attribute metaclass loaded'); + +is($meta->instance_metaclass, 'MyMetaClass::Instance', '... Correct instance metaclass'); +ok(is_class_loaded('MyMetaClass::Instance'), '... instance metaclass loaded'); + +is($meta->method_metaclass, 'MyMetaClass::Method', '... Correct method metaclass'); +ok(is_class_loaded('MyMetaClass::Method'), '... method metaclass loaded'); + +done_testing; diff --git a/t/cmop/metaclass_reinitialize.t b/t/cmop/metaclass_reinitialize.t new file mode 100644 index 0000000..e4a98f3 --- /dev/null +++ b/t/cmop/metaclass_reinitialize.t @@ -0,0 +1,205 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use metaclass; + sub foo {} + Foo->meta->add_attribute('bar'); +} + +sub check_meta_sanity { + my ($meta, $class) = @_; + isa_ok($meta, 'Class::MOP::Class'); + is($meta->name, $class); + ok($meta->has_method('foo')); + isa_ok($meta->get_method('foo'), 'Class::MOP::Method'); + ok($meta->has_attribute('bar')); + isa_ok($meta->get_attribute('bar'), 'Class::MOP::Attribute'); +} + +can_ok('Foo', 'meta'); + +my $meta = Foo->meta; +check_meta_sanity($meta, 'Foo'); + +is( exception { + $meta = $meta->reinitialize($meta->name); +}, undef ); +check_meta_sanity($meta, 'Foo'); + +is( exception { + $meta = $meta->reinitialize($meta); +}, undef ); +check_meta_sanity($meta, 'Foo'); + +like( exception { + $meta->reinitialize(''); +}, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); + +like( exception { + $meta->reinitialize($meta->new_object); +}, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); + +{ + package Bar::Meta::Method; + use parent 'Class::MOP::Method'; + __PACKAGE__->meta->add_attribute('test', accessor => 'test'); +} + +{ + package Bar::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + __PACKAGE__->meta->add_attribute('tset', accessor => 'tset'); +} + +{ + package Bar; + use metaclass; + Bar->meta->add_method('foo' => Bar::Meta::Method->wrap(sub {}, name => 'foo', package_name => 'Bar')); + Bar->meta->add_attribute(Bar::Meta::Attribute->new('bar')); +} + +$meta = Bar->meta; +check_meta_sanity($meta, 'Bar'); +isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +is( exception { + $meta = $meta->reinitialize('Bar'); +}, undef ); +check_meta_sanity($meta, 'Bar'); +isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); + +Bar->meta->get_method('foo')->test('FOO'); +Bar->meta->get_attribute('bar')->tset('OOF'); + +is(Bar->meta->get_method('foo')->test, 'FOO'); +is(Bar->meta->get_attribute('bar')->tset, 'OOF'); +is( exception { + $meta = $meta->reinitialize('Bar'); +}, undef ); +is(Bar->meta->get_method('foo')->test, 'FOO'); +is(Bar->meta->get_attribute('bar')->tset, 'OOF'); + +{ + package Baz::Meta::Attribute; + use parent 'Class::MOP::Attribute'; +} + +{ + package Baz::Meta::Method; + use parent 'Class::MOP::Method'; +} + +{ + package Baz; + use metaclass meta_name => undef; + + sub foo {} + Class::MOP::class_of('Baz')->add_attribute('bar'); +} + +$meta = Class::MOP::class_of('Baz'); +check_meta_sanity($meta, 'Baz'); +ok(!$meta->get_method('foo')->isa('Baz::Meta::Method')); +ok(!$meta->get_attribute('bar')->isa('Baz::Meta::Attribute')); +is( exception { + $meta = $meta->reinitialize( + 'Baz', + attribute_metaclass => 'Baz::Meta::Attribute', + method_metaclass => 'Baz::Meta::Method' + ); +}, undef ); +check_meta_sanity($meta, 'Baz'); +isa_ok($meta->get_method('foo'), 'Baz::Meta::Method'); +isa_ok($meta->get_attribute('bar'), 'Baz::Meta::Attribute'); + +{ + package Quux; + use metaclass + attribute_metaclass => 'Bar::Meta::Attribute', + method_metaclass => 'Bar::Meta::Method'; + + sub foo {} + Quux->meta->add_attribute('bar'); +} + +$meta = Quux->meta; +check_meta_sanity($meta, 'Quux'); +isa_ok(Quux->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Quux->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +like( exception { + $meta = $meta->reinitialize( + 'Quux', + attribute_metaclass => 'Baz::Meta::Attribute', + method_metaclass => 'Baz::Meta::Method', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Quuux::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + + sub install_accessors {} +} + +{ + package Quuux; + use metaclass; + sub foo {} + Quuux->meta->add_attribute('bar', reader => 'bar'); +} + +$meta = Quuux->meta; +check_meta_sanity($meta, 'Quuux'); +ok($meta->has_method('bar')); +is( exception { + $meta = $meta->reinitialize( + 'Quuux', + attribute_metaclass => 'Quuux::Meta::Attribute', + ); +}, undef ); +check_meta_sanity($meta, 'Quuux'); +ok(!$meta->has_method('bar')); + +{ + package Blah::Meta::Method; + use parent 'Class::MOP::Method'; + + __PACKAGE__->meta->add_attribute('foo', reader => 'foo', default => 'TEST'); +} + +{ + package Blah::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + + __PACKAGE__->meta->add_attribute('oof', reader => 'oof', default => 'TSET'); +} + +{ + package Blah; + use metaclass no_meta => 1; + sub foo {} + Class::MOP::class_of('Blah')->add_attribute('bar'); +} + +$meta = Class::MOP::class_of('Blah'); +check_meta_sanity($meta, 'Blah'); +is( exception { + $meta = Class::MOP::Class->reinitialize( + 'Blah', + attribute_metaclass => 'Blah::Meta::Attribute', + method_metaclass => 'Blah::Meta::Method', + ); +}, undef ); +check_meta_sanity($meta, 'Blah'); +can_ok($meta->get_method('foo'), 'foo'); +is($meta->get_method('foo')->foo, 'TEST'); +can_ok($meta->get_attribute('bar'), 'oof'); +is($meta->get_attribute('bar')->oof, 'TSET'); + +done_testing; diff --git a/t/cmop/method.t b/t/cmop/method.t new file mode 100644 index 0000000..dd15b8a --- /dev/null +++ b/t/cmop/method.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Method; + +my $method = Class::MOP::Method->wrap( + sub {1}, + package_name => 'main', + name => '__ANON__', +); +is( $method->meta, Class::MOP::Method->meta, + '... instance and class both lead to the same meta' ); + +is( $method->package_name, 'main', '... our package is main::' ); +is( $method->name, '__ANON__', '... our sub name is __ANON__' ); +is( $method->fully_qualified_name, 'main::__ANON__', + '... our subs full name is main::__ANON__' ); +is( $method->original_method, undef, '... no original_method ' ); +is( $method->original_package_name, 'main', + '... the original_package_name is the same as package_name' ); +is( $method->original_name, '__ANON__', + '... the original_name is the same as name' ); +is( $method->original_fully_qualified_name, 'main::__ANON__', + '... the original_fully_qualified_name is the same as fully_qualified_name' +); +ok( !$method->is_stub, + '... the method is not a stub' ); + +isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} ); +isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} ); +isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} ); + +isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} ); +isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} ); +isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} ); +isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} ); + +my $meta = Class::MOP::Method->meta; +isa_ok( $meta, 'Class::MOP::Class' ); + +foreach my $method_name ( + qw( + wrap + package_name + name + ) + ) { + ok( $meta->has_method($method_name), + '... Class::MOP::Method->has_method(' . $method_name . ')' ); + my $method = $meta->get_method($method_name); + is( $method->package_name, 'Class::MOP::Method', + '... our package is Class::MOP::Method' ); + is( $method->name, $method_name, + '... our sub name is "' . $method_name . '"' ); +} + +isnt( exception { + Class::MOP::Method->wrap(); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap('Fail'); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( [] ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'} ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' ); +}, undef, '... bad args for &wrap' ); + +is( exception { + Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ), + name => '__ANON__', package_name => 'Foo::Bar' ); +}, undef, '... blessed coderef to &wrap' ); + +my $clone = $method->clone( + package_name => 'NewPackage', + name => 'new_name', +); + +isa_ok( $clone, 'Class::MOP::Method' ); +is( $clone->package_name, 'NewPackage', + '... cloned method has new package name' ); +is( $clone->name, 'new_name', '... cloned method has new sub name' ); +is( $clone->fully_qualified_name, 'NewPackage::new_name', + '... cloned method has new fq name' ); +is( $clone->original_method, $method, + '... cloned method has correct original_method' ); +is( $clone->original_package_name, 'main', + '... cloned method has correct original_package_name' ); +is( $clone->original_name, '__ANON__', + '... cloned method has correct original_name' ); +is( $clone->original_fully_qualified_name, 'main::__ANON__', + '... cloned method has correct original_fully_qualified_name' ); + +my $clone2 = $clone->clone( + package_name => 'NewerPackage', + name => 'newer_name', +); + +is( $clone2->package_name, 'NewerPackage', + '... clone of clone has new package name' ); +is( $clone2->name, 'newer_name', '... clone of clone has new sub name' ); +is( $clone2->fully_qualified_name, 'NewerPackage::newer_name', + '... clone of clone new fq name' ); +is( $clone2->original_method, $clone, + '... cloned method has correct original_method' ); +is( $clone2->original_package_name, 'main', + '... original_package_name follows clone chain' ); +is( $clone2->original_name, '__ANON__', + '... original_name follows clone chain' ); +is( $clone2->original_fully_qualified_name, 'main::__ANON__', + '... original_fully_qualified_name follows clone chain' ); + +Class::MOP::Class->create( + 'Method::Subclass', + superclasses => ['Class::MOP::Method'], + attributes => [ + Class::MOP::Attribute->new( + foo => ( + accessor => 'foo', + ) + ), + ], +); + +my $wrapped = Method::Subclass->wrap($method, foo => 'bar'); +isa_ok($wrapped, 'Method::Subclass'); +isa_ok($wrapped, 'Class::MOP::Method'); +is($wrapped->foo, 'bar', 'attribute set properly'); +is($wrapped->package_name, 'main', 'package_name copied properly'); +is($wrapped->name, '__ANON__', 'method name copied properly'); + +my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO'); +is($wrapped2->name, 'FOO', 'got a new method name'); + +{ + package Foo; + + sub full {1} + sub stub; +} + +{ + my $meta = Class::MOP::Class->initialize('Foo'); + + ok( $meta->has_method($_), "Foo class has $_ method" ) + for qw( full stub ); + + my $full = $meta->get_method('full'); + ok( !$full->is_stub, 'full is not a stub' ); + + my $stub = $meta->get_method('stub'); + + ok( $stub->is_stub, 'stub is a stub' ); +} + +done_testing; diff --git a/t/cmop/method_modifiers.t b/t/cmop/method_modifiers.t new file mode 100644 index 0000000..cb7078d --- /dev/null +++ b/t/cmop/method_modifiers.t @@ -0,0 +1,203 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Method; + +# test before and afters +{ + my $trace = ''; + + my $method = Class::MOP::Method->wrap( + body => sub { $trace .= 'primary' }, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + $method->(); + is( $trace, 'primary', '... got the right return value from method' ); + $trace = ''; + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + $wrapped->(); + is( $trace, 'primary', + '... got the right return value from the wrapped method' ); + $trace = ''; + + is( exception { + $wrapped->add_before_modifier( sub { $trace .= 'before -> ' } ); + }, undef, '... added the before modifier okay' ); + + $wrapped->(); + is( $trace, 'before -> primary', + '... got the right return value from the wrapped method (w/ before)' + ); + $trace = ''; + + is( exception { + $wrapped->add_after_modifier( sub { $trace .= ' -> after' } ); + }, undef, '... added the after modifier okay' ); + + $wrapped->(); + is( $trace, 'before -> primary -> after', + '... got the right return value from the wrapped method (w/ before)' + ); + $trace = ''; +} + +# test around method +{ + my $method = Class::MOP::Method->wrap( + sub {4}, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + is( $method->(), 4, '... got the right value from the wrapped method' ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + is( $wrapped->(), 4, '... got the right value from the wrapped method' ); + + is( exception { + $wrapped->add_around_modifier( sub { ( 3, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 2, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 1, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 0, $_[0]->() ) } ); + }, undef, '... added the around modifier okay' ); + + is_deeply( + [ $wrapped->() ], + [ 0, 1, 2, 3, 4 ], + '... got the right results back from the around methods (in list context)' + ); + + is( scalar $wrapped->(), 4, + '... got the right results back from the around methods (in scalar context)' + ); +} + +{ + my @tracelog; + + my $method = Class::MOP::Method->wrap( + sub { push @tracelog => 'primary' }, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + is( exception { + $wrapped->add_before_modifier( sub { push @tracelog => 'before 1' } ); + $wrapped->add_before_modifier( sub { push @tracelog => 'before 2' } ); + $wrapped->add_before_modifier( sub { push @tracelog => 'before 3' } ); + }, undef, '... added the before modifier okay' ); + + is( exception { + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 1'; $_[0]->(); } ); + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 2'; $_[0]->(); } ); + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 3'; $_[0]->(); } ); + }, undef, '... added the around modifier okay' ); + + is( exception { + $wrapped->add_after_modifier( sub { push @tracelog => 'after 1' } ); + $wrapped->add_after_modifier( sub { push @tracelog => 'after 2' } ); + $wrapped->add_after_modifier( sub { push @tracelog => 'after 3' } ); + }, undef, '... added the after modifier okay' ); + + $wrapped->(); + is_deeply( + \@tracelog, + [ + 'before 3', 'before 2', 'before 1', # last-in-first-out order + 'around 3', 'around 2', 'around 1', # last-in-first-out order + 'primary', + 'after 1', 'after 2', 'after 3', # first-in-first-out order + ], + '... got the right tracelog from all our before/around/after methods' + ); +} + +# test introspection +{ + sub before1 { + } + + sub before2 { + } + + sub before3 { + } + + sub after1 { + } + + sub after2 { + } + + sub after3 { + } + + sub around1 { + } + + sub around2 { + } + + sub around3 { + } + + sub orig { + } + + my $method = Class::MOP::Method->wrap( + body => \&orig, + package_name => 'main', + name => '__ANON__', + ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + + $wrapped->add_before_modifier($_) + for \&before1, \&before2, \&before3; + + $wrapped->add_after_modifier($_) + for \&after1, \&after2, \&after3; + + $wrapped->add_around_modifier($_) + for \&around1, \&around2, \&around3; + + is( $wrapped->get_original_method, $method, + 'check get_original_method' ); + + is_deeply( [ $wrapped->before_modifiers ], + [ \&before3, \&before2, \&before1 ], + 'check before_modifiers' ); + + is_deeply( [ $wrapped->after_modifiers ], + [ \&after1, \&after2, \&after3 ], + 'check after_modifiers' ); + + is_deeply( [ $wrapped->around_modifiers ], + [ \&around3, \&around2, \&around1 ], + 'check around_modifiers' ); +} + +done_testing; diff --git a/t/cmop/methods.t b/t/cmop/methods.t new file mode 100644 index 0000000..a7a5d46 --- /dev/null +++ b/t/cmop/methods.t @@ -0,0 +1,431 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util qw/reftype/; +use Sub::Name; + +use Class::MOP; +use Class::MOP::Class; +use Class::MOP::Method; + +{ + # This package tries to test &has_method as exhaustively as + # possible. More corner cases are welcome :) + package Foo; + + # import a sub + use Scalar::Util 'blessed'; + + sub pie; + sub cake (); + + use constant FOO_CONSTANT => 'Foo-CONSTANT'; + + # define a sub in package + sub bar {'Foo::bar'} + *baz = \&bar; + + # create something with the typeglob inside the package + *baaz = sub {'Foo::baaz'}; + + { # method named with Sub::Name inside the package scope + no strict 'refs'; + *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'}; + } + + # We hateses the "used only once" warnings + { + my $temp1 = \&Foo::baz; + my $temp2 = \&Foo::baaz; + } + + package OinkyBoinky; + our @ISA = "Foo"; + + sub elk {'OinkyBoinky::elk'} + + package main; + + sub Foo::blah { $_[0]->Foo::baz() } + + { + no strict 'refs'; + *{'Foo::bling'} = sub {'$$Bling$$'}; + *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'}; + *{'Foo::boom'} = Sub::Name::subname 'boom' => sub {'!BOOM!'}; + + eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }"; + } +} + +my $Foo = Class::MOP::Class->initialize('Foo'); + +is join(' ', sort $Foo->get_method_list), + 'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie'; + +ok( $Foo->has_method('pie'), '... got the method stub pie' ); +ok( $Foo->has_method('cake'), '... got the constant method stub cake' ); + +my $foo = sub {'Foo::foo'}; + +ok( !Scalar::Util::blessed($foo), + '... our method is not yet blessed' ); + +is( exception { + $Foo->add_method( 'foo' => $foo ); +}, undef, '... we added the method successfully' ); + +my $foo_method = $Foo->get_method('foo'); + +isa_ok( $foo_method, 'Class::MOP::Method' ); + +is( $foo_method->name, 'foo', '... got the right name for the method' ); +is( $foo_method->package_name, 'Foo', + '... got the right package name for the method' ); + +ok( $Foo->has_method('foo'), + '... Foo->has_method(foo) (defined with Sub::Name)' ); + +is( $Foo->get_method('foo')->body, $foo, + '... Foo->get_method(foo) == \&foo' ); +is( $Foo->get_method('foo')->execute, 'Foo::foo', + '... _method_foo->execute returns "Foo::foo"' ); +is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' ); + +my $bork_blessed = bless sub { }, 'Non::Meta::Class'; + +is( exception { + $Foo->add_method('bork', $bork_blessed); +}, undef, 'can add blessed sub as method'); + +# now check all our other items ... + +ok( $Foo->has_method('FOO_CONSTANT'), + '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' ); +ok( !$Foo->has_method('bling'), + '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))' +); + +ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' ); +ok( $Foo->has_method('baz'), + '... Foo->has_method(baz) (typeglob aliased within Foo)' ); +ok( $Foo->has_method('baaz'), + '... Foo->has_method(baaz) (typeglob aliased within Foo)' ); +ok( $Foo->has_method('floob'), + '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)' +); +ok( $Foo->has_method('blah'), + '... Foo->has_method(blah) (defined in main:: using fully qualified package name)' +); +ok( $Foo->has_method('bang'), + '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)' +); +ok( $Foo->has_method('evaled_foo'), + '... Foo->has_method(evaled_foo) (evaled in main::)' ); + +my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky'); + +ok( $OinkyBoinky->has_method('elk'), + "the method 'elk' is defined in OinkyBoinky" ); + +ok( !$OinkyBoinky->has_method('bar'), + "the method 'bar' is not defined in OinkyBoinky" ); + +ok( my $bar = $OinkyBoinky->find_method_by_name('bar'), + "but if you look in the inheritence chain then 'bar' does exist" ); + +is( reftype( $bar->body ), "CODE", "the returned value is a code ref" ); + +# calling get_method blessed them all +for my $method_name ( + qw/baaz + bar + baz + floob + blah + bang + bork + evaled_foo + FOO_CONSTANT/ + ) { + isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' ); + { + no strict 'refs'; + is( $Foo->get_method($method_name)->body, + \&{ 'Foo::' . $method_name }, + '... body matches CODE ref in package for ' . $method_name ); + } +} + +for my $method_name ( + qw/ + bling + / + ) { + is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE', + '... got the __ANON__ methods' ); + { + no strict 'refs'; + is( $Foo->get_package_symbol( '&' . $method_name ), + \&{ 'Foo::' . $method_name }, + '... symbol matches CODE ref in package for ' . $method_name ); + } +} + +ok( !$Foo->has_method('blessed'), + '... !Foo->has_method(blessed) (imported into Foo)' ); +ok( !$Foo->has_method('boom'), + '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)' +); + +ok( !$Foo->has_method('not_a_real_method'), + '... !Foo->has_method(not_a_real_method) (does not exist)' ); +is( $Foo->get_method('not_a_real_method'), undef, + '... Foo->get_method(not_a_real_method) == undef' ); + +is_deeply( + [ sort $Foo->get_method_list ], + [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob foo pie)], + '... got the right method list for Foo' +); + +my @universal_methods = qw/isa can VERSION/; +push @universal_methods, 'DOES' if $] >= 5.010; + +is_deeply( + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } $Foo->get_all_methods() + ], + [ + map { $_->name => $_ } + map { $Foo->find_method_by_name($_) } + sort qw( + FOO_CONSTANT + baaz + bang + bar + baz + blah + bork + cake + evaled_foo + floob + foo + pie + ), + @universal_methods, + ], + '... got the right list of applicable methods for Foo' +); + +is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' ); +ok( !$Foo->has_method('foo'), + '... !Foo->has_method(foo) we just removed it' ); +isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' ); + +is_deeply( + [ sort $Foo->get_method_list ], + [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob pie)], + '... got the right method list for Foo' +); + +# ... test our class creator + +my $Bar = Class::MOP::Class->create( + package => 'Bar', + superclasses => ['Foo'], + methods => { + foo => sub {'Bar::foo'}, + bar => sub {'Bar::bar'}, + } +); +isa_ok( $Bar, 'Class::MOP::Class' ); + +ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' ); +ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' ); + +is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' ); +is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' ); + +is( exception { + $Bar->add_method( 'foo' => sub {'Bar::foo v2'} ); +}, undef, '... overwriting a method is fine' ); + +is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ], + [ "Bar", "foo" ], "subname applied to anonymous method" ); + +ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' ); +is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' ); + +is_deeply( + [ sort $Bar->get_method_list ], + [qw(bar foo meta)], + '... got the right method list for Bar' +); + +is_deeply( + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } $Bar->get_all_methods() + ], + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } ( + $Foo->get_method('FOO_CONSTANT'), + $Foo->get_method('baaz'), + $Foo->get_method('bang'), + $Bar->get_method('bar'), + ( + map { $Foo->get_method($_) } + qw( + baz + blah + bork + cake + evaled_foo + floob + ) + ), + $Bar->get_method('foo'), + $Bar->get_method('meta'), + $Foo->get_method('pie'), + ( map { $Bar->find_next_method_by_name($_) } @universal_methods ) + ) + ], + '... got the right list of applicable methods for Bar' +); + +my $method = Class::MOP::Method->wrap( + name => 'objecty', + package_name => 'Whatever', + body => sub {q{I am an object, and I feel an object's pain}}, +); + +Bar->meta->add_method( $method->name, $method ); + +my $new_method = Bar->meta->get_method('objecty'); + +isnt( $method, $new_method, + 'add_method clones method objects as they are added' ); +is( $new_method->original_method, $method, + '... the cloned method has the correct original method' ) + or diag $new_method->dump; + +{ + package CustomAccessor; + + use Class::MOP; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->add_attribute( + foo => ( + accessor => 'foo', + ) + ); + + { + no warnings 'redefine', 'once'; + *foo = sub { + my $self = shift; + $self->{custom_store} = $_[0]; + }; + } + + $meta->add_around_method_modifier( + 'foo', + sub { + my $orig = shift; + $orig->(@_); + } + ); + + sub new { + return bless {}, shift; + } +} + +{ + my $o = CustomAccessor->new; + my $str = 'string'; + + $o->foo($str); + + is( + $o->{custom_store}, $str, + 'Custom glob-assignment-created accessor still has method modifier' + ); +} + +{ + # Since the sub reference below is not a closure, Perl caches it and uses + # the same reference each time through the loop. See RT #48985 for the + # bug. + foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) { + my $meta = Class::MOP::Class->create($ns); + + my $sub = sub { }; + + $meta->add_method( 'foo', $sub ); + + my $method = $meta->get_method('foo'); + ok( $method, 'Got the foo method back' ); + } +} + +{ + package HasConstants; + + use constant FOO => 1; + use constant BAR => []; + use constant BAZ => {}; + use constant UNDEF => undef; + + sub quux {1} + sub thing {1} +} + +my $HC = Class::MOP::Class->initialize('HasConstants'); + +is_deeply( + [ sort $HC->get_method_list ], + [qw( BAR BAZ FOO UNDEF quux thing )], + 'get_method_list handles constants properly' +); + +is_deeply( + [ sort map { $_->name } $HC->_get_local_methods ], + [qw( BAR BAZ FOO UNDEF quux thing )], + '_get_local_methods handles constants properly' +); + +{ + package DeleteFromMe; + sub foo { 1 } +} + +{ + my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe'); + ok($DFMmeta->get_method('foo')); + + delete $DeleteFromMe::{foo}; + + ok(!$DFMmeta->get_method('foo')); + ok(!DeleteFromMe->can('foo')); +} + +{ + my $baz_meta = Class::MOP::Class->initialize('Baz'); + $baz_meta->add_method(foo => sub { }); + my $stash = Package::Stash->new('Baz'); + $stash->remove_symbol('&foo'); + is_deeply([$baz_meta->get_method_list], [], "method is deleted"); + ok(!Baz->can('foo'), "Baz can't foo"); +} + + +done_testing; diff --git a/t/cmop/modify_parent_method.t b/t/cmop/modify_parent_method.t new file mode 100644 index 0000000..8ba6c43 --- /dev/null +++ b/t/cmop/modify_parent_method.t @@ -0,0 +1,99 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my @calls; + +{ + package Parent; + + use strict; + use warnings; + use metaclass; + + use Carp 'confess'; + + sub method { push @calls, 'Parent::method' } + + package Child; + + use strict; + use warnings; + use metaclass; + + use parent -norequire => 'Parent'; + + Child->meta->add_around_method_modifier( + 'method' => sub { + my $orig = shift; + push @calls, 'before Child::method'; + $orig->(@_); + push @calls, 'after Child::method'; + } + ); +} + +Parent->method; + +is_deeply( + [ splice @calls ], + [ + 'Parent::method', + ] +); + +Child->method; + +is_deeply( + [ splice @calls ], + [ + 'before Child::method', + 'Parent::method', + 'after Child::method', + ] +); + +{ + package Parent; + + Parent->meta->add_around_method_modifier( + 'method' => sub { + my $orig = shift; + push @calls, 'before Parent::method'; + $orig->(@_); + push @calls, 'after Parent::method'; + } + ); +} + +Parent->method; + +is_deeply( + [ splice @calls ], + [ + 'before Parent::method', + 'Parent::method', + 'after Parent::method', + ] +); + +Child->method; + +TODO: { + local $TODO = "pending fix"; + is_deeply( + [ splice @calls ], + [ + 'before Child::method', + 'before Parent::method', + 'Parent::method', + 'after Parent::method', + 'after Child::method', + ], + "cache is correctly invalidated when the parent method is wrapped" + ); +} + +done_testing; diff --git a/t/cmop/new_and_clone_metaclasses.t b/t/cmop/new_and_clone_metaclasses.t new file mode 100644 index 0000000..1212c97 --- /dev/null +++ b/t/cmop/new_and_clone_metaclasses.t @@ -0,0 +1,124 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +use lib 't/cmop/lib'; + +# make sure the Class::MOP::Class->meta does the right thing + +my $meta = Class::MOP::Class->meta(); +isa_ok($meta, 'Class::MOP::Class'); + +my $new_meta = $meta->new_object('package' => 'Class::MOP::Class'); +isa_ok($new_meta, 'Class::MOP::Class'); +is($new_meta, $meta, '... it still creates the singleton'); + +my $cloned_meta = $meta->clone_object($meta); +isa_ok($cloned_meta, 'Class::MOP::Class'); +is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it'); + +# make sure other metaclasses do the right thing + +{ + package Foo; + use metaclass; +} + +my $foo_meta = Foo->meta; +isa_ok($foo_meta, 'Class::MOP::Class'); + +is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); +is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton'); + +# make sure subclassed of Class::MOP::Class do the right thing + +my $my_meta = MyMetaClass->meta; +isa_ok($my_meta, 'Class::MOP::Class'); + +my $new_my_meta = $my_meta->new_object('package' => 'MyMetaClass'); +isa_ok($new_my_meta, 'Class::MOP::Class'); +is($new_my_meta, $my_meta, '... even subclasses still create the singleton'); + +my $cloned_my_meta = $meta->clone_object($my_meta); +isa_ok($cloned_my_meta, 'Class::MOP::Class'); +is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it'); + +is($my_meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)'); +is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)'); + +# now create a metaclass for real + +my $bar_meta = $my_meta->new_object('package' => 'Bar'); +isa_ok($bar_meta, 'Class::MOP::Class'); + +is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass'); +is($bar_meta->version, undef, '... Bar does not exists, so it has no version'); + +$bar_meta->superclasses('Foo'); + +# check with MyMetaClass + +{ + package Baz; + use metaclass 'MyMetaClass'; +} + +my $baz_meta = Baz->meta; +isa_ok($baz_meta, 'Class::MOP::Class'); +isa_ok($baz_meta, 'MyMetaClass'); + +is($my_meta->new_object('package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton'); +is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton'); + +$baz_meta->superclasses('Bar'); + +# now create a regular objects for real + +my $foo = $foo_meta->new_object(); +isa_ok($foo, 'Foo'); + +my $bar = $bar_meta->new_object(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +my $baz = $baz_meta->new_object(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +my $cloned_foo = $foo_meta->clone_object($foo); +isa_ok($cloned_foo, 'Foo'); + +isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo'); + +# check some errors + +isnt( exception { + $foo_meta->clone_object($meta); +}, undef, '... this dies as expected' ); + +# test stuff + +{ + package FooBar; + use metaclass; + + FooBar->meta->add_attribute('test'); +} + +my $attr = FooBar->meta->get_attribute('test'); +isa_ok($attr, 'Class::MOP::Attribute'); + +my $attr_clone = $attr->clone(); +isa_ok($attr_clone, 'Class::MOP::Attribute'); + +isnt($attr, $attr_clone, '... we successfully cloned our attributes'); +is($attr->associated_class, + $attr_clone->associated_class, + '... we successfully did not clone our associated metaclass'); + +done_testing; diff --git a/t/cmop/null_stash.t b/t/cmop/null_stash.t new file mode 100644 index 0000000..ee5d363 --- /dev/null +++ b/t/cmop/null_stash.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; +my $non = Class::MOP::Class->initialize('Non::Existent::Package'); +$non->get_method('foo'); + +pass("empty stashes don't segfault"); + +done_testing; diff --git a/t/cmop/numeric_defaults.t b/t/cmop/numeric_defaults.t new file mode 100644 index 0000000..4c3102a --- /dev/null +++ b/t/cmop/numeric_defaults.t @@ -0,0 +1,124 @@ +use strict; +use warnings; +use Test::More; +use B; +use Class::MOP; + +my @int_defaults = ( + 100, + -2, + 01234, + 0xFF, +); + +my @num_defaults = ( + 10.5, + -20.0, + 1e3, + 1.3e-10, +); + +my @string_defaults = ( + 'foo', + '', + '100', + '10.5', + '1e3', + '0 but true', + '01234', + '09876', + '0xFF', +); + +for my $default (@int_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)"); + ok(!($flags & B::SVf_POK), "not a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)"); + ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); + } +} + +for my $default (@num_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)"); + ok(!($flags & B::SVf_POK), "not a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)"); + ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); + } +} + +for my $default (@string_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_POK, "it's a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)"); + } +} + +done_testing; diff --git a/t/cmop/package_variables.t b/t/cmop/package_variables.t new file mode 100644 index 0000000..bcf960a --- /dev/null +++ b/t/cmop/package_variables.t @@ -0,0 +1,230 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use metaclass; +} + +=pod + +This is the same test as 080_meta_package.t just here +we call all the methods through Class::MOP::Class. + +=cut + +# ---------------------------------------------------------------------- +## tests adding a HASH + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +is( exception { + Foo->meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully' ); + +# ... scalar should NOT be created here + +ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('$baz' => 10); +}, undef, '... created $Foo::baz successfully' ); + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); +}, undef, '... created &Foo::funk successfully' ); + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is( exception { + Foo->meta->add_package_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = Foo->meta->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is( exception { + Foo->meta->remove_package_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +done_testing; diff --git a/t/cmop/random_eval_bug.t b/t/cmop/random_eval_bug.t new file mode 100644 index 0000000..285edb0 --- /dev/null +++ b/t/cmop/random_eval_bug.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +=pod + +This tests a bug which is fixed in 0.22 by localizing all the $@'s around any +evals. + +This a real pain to track down. + +Moral of the story: + + ALWAYS localize your globals :) + +=cut + +{ + package Company; + use strict; + use warnings; + use metaclass; + + sub new { + my ($class) = @_; + return bless {} => $class; + } + + sub employees { + die "This didnt work"; + } + + sub DESTROY { + my $self = shift; + foreach + my $method ( $self->meta->find_all_methods_by_name('DEMOLISH') ) { + $method->{code}->($self); + } + } +} + +eval { + my $c = Company->new(); + $c->employees(); +}; +ok( $@, '... we die correctly with bad args' ); + +done_testing; diff --git a/t/cmop/rebless_instance.t b/t/cmop/rebless_instance.t new file mode 100644 index 0000000..4cbefd6 --- /dev/null +++ b/t/cmop/rebless_instance.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util 'blessed'; + +{ + package Parent; + use metaclass; + + sub new { bless {} => shift } + sub whoami { "parent" } + sub parent { "parent" } + + package Child; + use metaclass; + use parent -norequire => 'Parent'; + + sub whoami { "child" } + sub child { "child" } + + package LeftField; + use metaclass; + + sub new { bless {} => shift } + sub whoami { "leftfield" } + sub myhax { "areleet" } +} + +# basic tests +my $foo = Parent->new; +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); + +Child->meta->rebless_instance($foo); +is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance'); +is($foo->whoami, "child", 'reblessed->whoami gives child'); +is($foo->parent, "parent", 'reblessed->parent gives parent'); +is($foo->child, "child", 'reblessed->child gives child'); + +like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ ); + +like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./ ); + +Parent->meta->rebless_instance_back($foo); +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); + +like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ ); + +like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./ ); + +# make sure our ->meta is still sane +my $bar = Parent->new; +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + +Child->meta->rebless_instance($bar); +is(blessed($bar), 'Child', "rebless really reblessed"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child"); + +ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method'); +ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method'); +ok(!$bar->meta->has_method('new'), 'no "new" method in this class'); +ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('child'), 'metaclass has "child" method'); + +is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); + +Parent->meta->rebless_instance_back($bar); +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + +done_testing; diff --git a/t/cmop/rebless_instance_away.t b/t/cmop/rebless_instance_away.t new file mode 100644 index 0000000..ad411ec --- /dev/null +++ b/t/cmop/rebless_instance_away.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +my @calls; + +do { + package My::Meta::Class; + use parent 'Class::MOP::Class'; + + sub rebless_instance_away { + push @calls, [@_]; + shift->SUPER::rebless_instance_away(@_); + } +}; + +do { + package Parent; + use metaclass 'My::Meta::Class'; + + package Child; + use metaclass 'My::Meta::Class'; + use parent -norequire => 'Parent'; +}; + +my $person = Parent->meta->new_object; +Child->meta->rebless_instance($person); + +is(@calls, 1, "one call to rebless_instance_away"); +is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass'); +is($calls[0][1], $person, 'with the instance'); +is($calls[0][2]->name, 'Child', 'and the new metaclass'); +splice @calls; + +Child->meta->rebless_instance($person, foo => 1); +is($calls[0][0]->name, 'Child'); +is($calls[0][1], $person); +is($calls[0][2]->name, 'Child'); +is($calls[0][3], 'foo'); +is($calls[0][4], 1); +splice @calls; + +done_testing; diff --git a/t/cmop/rebless_overload.t b/t/cmop/rebless_overload.t new file mode 100644 index 0000000..c3a7a68 --- /dev/null +++ b/t/cmop/rebless_overload.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +do { + package Without::Overloading; + sub new { bless {}, shift } + + package With::Overloading; + use parent -norequire => 'Without::Overloading'; + use overload q{""} => sub { "overloaded" }; +}; + +my $without = bless {}, "Without::Overloading"; +like("$without", qr/^Without::Overloading/, "no overloading"); + +my $with = With::Overloading->new; +is("$with", "overloaded", "initial overloading works"); + + +my $meta = Class::MOP::Class->initialize('With::Overloading'); + +$meta->rebless_instance($without); +is("$without", "overloaded", "overloading after reblessing works"); + +done_testing; diff --git a/t/cmop/rebless_with_extra_params.t b/t/cmop/rebless_with_extra_params.t new file mode 100644 index 0000000..2493ec4 --- /dev/null +++ b/t/cmop/rebless_with_extra_params.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use metaclass; + Foo->meta->add_attribute('bar' => (reader => 'bar')); + + sub new { (shift)->meta->new_object(@_) } + + package Bar; + use metaclass; + use parent -norequire => 'Foo'; + Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ')); +} + +# normal ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo, (baz => 'FOO-BAZ')) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo, (bar => 'FOO-BAR', baz => 'FOO-BAZ')) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); +} + +done_testing; diff --git a/t/cmop/scala_style_mixin_composition.t b/t/cmop/scala_style_mixin_composition.t new file mode 100644 index 0000000..428b77d --- /dev/null +++ b/t/cmop/scala_style_mixin_composition.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires { + 'SUPER' => 1.10, # skip all if not installed +}; + +=pod + +This test demonstrates how simple it is to create Scala Style +Class Mixin Composition. Below is an example taken from the +Scala web site's example section, and trancoded to Class::MOP. + +NOTE: +We require SUPER for this test to handle the issue with SUPER:: +being determined at compile time. + +L<http://scala.epfl.ch/intro/mixin.html> + +A class can only be used as a mixin in the definition of another +class, if this other class extends a subclass of the superclass +of the mixin. Since ColoredPoint3D extends Point3D and Point3D +extends Point2D which is the superclass of ColoredPoint2D, the +code above is well-formed. + + class Point2D(xc: Int, yc: Int) { + val x = xc; + val y = yc; + override def toString() = "x = " + x + ", y = " + y; + } + + class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) { + val color = c; + def setColor(newCol: String): Unit = color = newCol; + override def toString() = super.toString() + ", col = " + color; + } + + class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) { + val z = zc; + override def toString() = super.toString() + ", z = " + z; + } + + class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String) + extends Point3D(xc, yc, zc) + with ColoredPoint2D(xc, yc, col); + + + Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString()) + + "x = 1, y = 2, z = 3, col = blue" + +=cut + +use Scalar::Util 'blessed'; +use Carp 'confess'; + +sub ::with ($) { + # fetch the metaclass for the + # caller and the mixin arg + my $metaclass = (caller)->meta; + my $mixin = (shift)->meta; + + # according to Scala, the + # the superclass of our class + # must be a subclass of the + # superclass of the mixin (see above) + my ($super_meta) = $metaclass->superclasses(); + my ($super_mixin) = $mixin->superclasses(); + ($super_meta->isa($super_mixin)) + || confess "The superclass must extend a subclass of the superclass of the mixin"; + + # collect all the attributes + # and clone them so they can + # associate with the new class + my @attributes = map { + $mixin->get_attribute($_)->clone() + } $mixin->get_attribute_list; + + my %methods = map { + my $method = $mixin->get_method($_); + # we want to ignore accessors since + # they will be created with the attrs + (blessed($method) && $method->isa('Class::MOP::Method::Accessor')) + ? () : ($_ => $method) + } $mixin->get_method_list; + + # NOTE: + # I assume that locally defined methods + # and attributes get precedence over those + # from the mixin. + + # add all the attributes in .... + foreach my $attr (@attributes) { + $metaclass->add_attribute($attr) + unless $metaclass->has_attribute($attr->name); + } + + # add all the methods in .... + foreach my $method_name (keys %methods) { + $metaclass->add_method($method_name => $methods{$method_name}) + unless $metaclass->has_method($method_name); + } +} + +{ + package Point2D; + use metaclass; + + Point2D->meta->add_attribute('$x' => ( + accessor => 'x', + init_arg => 'x', + )); + + Point2D->meta->add_attribute('$y' => ( + accessor => 'y', + init_arg => 'y', + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + sub toString { + my $self = shift; + "x = " . $self->x . ", y = " . $self->y; + } + + package ColoredPoint2D; + our @ISA = ('Point2D'); + + ColoredPoint2D->meta->add_attribute('$color' => ( + accessor => 'color', + init_arg => 'color', + )); + + sub toString { + my $self = shift; + $self->SUPER() . ', col = ' . $self->color; + } + + package Point3D; + our @ISA = ('Point2D'); + + Point3D->meta->add_attribute('$z' => ( + accessor => 'z', + init_arg => 'z', + )); + + sub toString { + my $self = shift; + $self->SUPER() . ', z = ' . $self->z; + } + + package ColoredPoint3D; + our @ISA = ('Point3D'); + + ::with('ColoredPoint2D'); + +} + +my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue'); +isa_ok($colored_point_3d, 'ColoredPoint3D'); +isa_ok($colored_point_3d, 'Point3D'); +isa_ok($colored_point_3d, 'Point2D'); + +is($colored_point_3d->toString(), + 'x = 1, y = 2, z = 3, col = blue', + '... got the right toString method'); + +done_testing; diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t new file mode 100644 index 0000000..69128f2 --- /dev/null +++ b/t/cmop/self_introspection.t @@ -0,0 +1,359 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; +use Class::MOP::Class; +use Class::MOP::Package; +use Class::MOP::Module; + +{ + my $class = Class::MOP::Class->initialize('Foo'); + is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta'); +} + +my $class_mop_class_meta = Class::MOP::Class->meta(); +isa_ok($class_mop_class_meta, 'Class::MOP::Class'); + +my $class_mop_package_meta = Class::MOP::Package->meta(); +isa_ok($class_mop_package_meta, 'Class::MOP::Package'); + +my $class_mop_module_meta = Class::MOP::Module->meta(); +isa_ok($class_mop_module_meta, 'Class::MOP::Module'); + +my @class_mop_package_methods = qw( + _new + + initialize reinitialize create create_anon is_anon + _free_anon _anon_cache_key _anon_package_prefix + + name + namespace + + add_package_symbol get_package_symbol has_package_symbol + remove_package_symbol get_or_add_package_symbol + list_all_package_symbols get_all_package_symbols remove_package_glob + + _package_stash + + DESTROY +); + +my @class_mop_module_methods = qw( + _new + + _instantiate_module + + version authority identifier create + + _anon_cache_key _anon_package_prefix +); + +my @class_mop_class_methods = qw( + _new + + is_pristine + + initialize reinitialize create + + create_anon_class is_anon_class + _anon_cache_key _anon_package_prefix + + instance_metaclass get_meta_instance + _inline_create_instance + _inline_rebless_instance + _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot + _create_meta_instance + new_object clone_object + _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses + _inline_slot_initializer _inline_extra_init _inline_fallback_constructor + _inline_generate_instance _inline_params _inline_slot_initializers + _inline_init_attr_from_constructor _inline_init_attr_from_default + _generate_fallback_constructor + _eval_environment + _construct_instance + _construct_class_instance + _clone_instance + rebless_instance rebless_instance_back rebless_instance_away + _force_rebless_instance _fixup_attributes_after_rebless + _check_metaclass_compatibility + _check_class_metaclass_compatibility _check_single_metaclass_compatibility + _class_metaclass_is_compatible _single_metaclass_is_compatible + _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility + _fix_single_metaclass_incompatibility _base_metaclasses + _can_fix_metaclass_incompatibility + _class_metaclass_can_be_made_compatible + _single_metaclass_can_be_made_compatible + + _remove_generated_metaobjects + _restore_metaobjects_from + + add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies + add_dependent_meta_instance remove_dependent_meta_instance + invalidate_meta_instances invalidate_meta_instance + + superclasses subclasses direct_subclasses class_precedence_list + linearized_isa _method_lookup_order _superclasses_updated _superclass_metas + + get_all_method_names get_all_methods + find_method_by_name find_all_methods_by_name find_next_method_by_name + + add_before_method_modifier add_after_method_modifier add_around_method_modifier + + _attach_attribute + _post_add_attribute + remove_attribute + find_attribute_by_name + get_all_attributes + + is_mutable is_immutable make_mutable make_immutable + _initialize_immutable _install_inlined_code _inlined_methods + _add_inlined_method _inline_accessors _inline_constructor + _inline_destructor _immutable_options _real_ref_name + _rebless_as_immutable _rebless_as_mutable _remove_inlined_code + + _immutable_metaclass + immutable_trait immutable_options + constructor_name constructor_class destructor_class +); + +# check the class ... + +is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class'); + +foreach my $method_name (sort @class_mop_class_methods) { + ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_class_meta->get_method($method_name)->body, + \&{'Class::MOP::Class::' . $method_name}, + '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); + } +} + +## check the package .... + +is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package'); + +foreach my $method_name (sort @class_mop_package_methods) { + ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_package_meta->get_method($method_name)->body, + \&{'Class::MOP::Package::' . $method_name}, + '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); + } +} + +## check the module .... + +is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module'); + +foreach my $method_name (sort @class_mop_module_methods) { + ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_module_meta->get_method($method_name)->body, + \&{'Class::MOP::Module::' . $method_name}, + '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); + } +} + + +# check for imported functions which are not methods + +foreach my $non_method_name (qw( + confess + blessed + subname + svref_2object + )) { + ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); +} + +# check for the right attributes + +my @class_mop_package_attributes = ( + 'package', + 'namespace', +); + +my @class_mop_module_attributes = ( + 'version', + 'authority' +); + +my @class_mop_class_attributes = ( + 'superclasses', + 'instance_metaclass', + 'immutable_trait', + 'constructor_name', + 'constructor_class', + 'destructor_class', +); + +# check class + +is_deeply( + [ sort $class_mop_class_meta->get_attribute_list ], + [ sort @class_mop_class_attributes ], + '... got the right list of attributes' +); + +is_deeply( + [ sort keys %{$class_mop_class_meta->_attribute_map} ], + [ sort @class_mop_class_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_class_attributes) { + ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +# check module + +is_deeply( + [ sort $class_mop_package_meta->get_attribute_list ], + [ sort @class_mop_package_attributes ], + '... got the right list of attributes'); + +is_deeply( + [ sort keys %{$class_mop_package_meta->_attribute_map} ], + [ sort @class_mop_package_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_package_attributes) { + ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +# check package + +is_deeply( + [ sort $class_mop_module_meta->get_attribute_list ], + [ sort @class_mop_module_attributes ], + '... got the right list of attributes'); + +is_deeply( + [ sort keys %{$class_mop_module_meta->_attribute_map} ], + [ sort @class_mop_module_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_module_attributes) { + ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +## check the attributes themselves + +# ... package + +ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader'); +is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }'); + +ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg'); +is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package'); + +# ... class, but inherited from HasMethods +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader, + { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass }, + '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg, + 'method_metaclass', + '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); + +ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader, + { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass }, + '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg, + 'wrapped_method_metaclass', + '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); + + +# ... class, but inherited from HasAttributes + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader, + { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map }, + '... Class::MOP::Class attributes\'s a reader is &_attribute_map'); + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg, + 'attributes', + '... Class::MOP::Class attributes\'s a init_arg is attributes'); + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'), + {}, + '... Class::MOP::Class attributes\'s a default of {}'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader, + { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass }, + '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg, + 'attribute_metaclass', + '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default, + 'Class::MOP::Attribute', + '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute'); + +# check the values of some of the methods + +is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); +is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); + +if ( defined $Class::MOP::Class::VERSION ) { + ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)'); +} +is(${$class_mop_class_meta->get_package_symbol('$VERSION')}, + $Class::MOP::Class::VERSION, + '... Class::MOP::Class->get_package_symbol($VERSION)'); + +is_deeply( + [ $class_mop_class_meta->superclasses ], + [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods Class::MOP::Mixin::HasOverloads/ ], + '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]'); + +is_deeply( + [ $class_mop_class_meta->class_precedence_list ], + [ qw/ + Class::MOP::Class + Class::MOP::Module + Class::MOP::Package + Class::MOP::Object + Class::MOP::Mixin + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin + Class::MOP::Mixin::HasOverloads + Class::MOP::Mixin + / ], + '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]'); + +is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass'); +is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass'); +is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass'); + +done_testing; diff --git a/t/cmop/subclasses.t b/t/cmop/subclasses.t new file mode 100644 index 0000000..3104bf4 --- /dev/null +++ b/t/cmop/subclasses.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +do { + package Grandparent; + use metaclass; + + package Parent; + use metaclass; + use parent -norequire => 'Grandparent'; + + package Uncle; + use metaclass; + use parent -norequire => 'Grandparent'; + + package Son; + use metaclass; + use parent -norequire => 'Parent'; + + package Daughter; + use metaclass; + use parent -norequire => 'Parent'; + + package Cousin; + use metaclass; + use parent -norequire => 'Uncle'; +}; + +is_deeply([sort Grandparent->meta->subclasses], ['Cousin', 'Daughter', 'Parent', 'Son', 'Uncle']); +is_deeply([sort Parent->meta->subclasses], ['Daughter', 'Son']); +is_deeply([sort Uncle->meta->subclasses], ['Cousin']); +is_deeply([sort Son->meta->subclasses], []); +is_deeply([sort Daughter->meta->subclasses], []); +is_deeply([sort Cousin->meta->subclasses], []); + +is_deeply([sort Grandparent->meta->direct_subclasses], ['Parent', 'Uncle']); +is_deeply([sort Parent->meta->direct_subclasses], ['Daughter', 'Son']); +is_deeply([sort Uncle->meta->direct_subclasses], ['Cousin']); +is_deeply([sort Son->meta->direct_subclasses], []); +is_deeply([sort Daughter->meta->direct_subclasses], []); +is_deeply([sort Cousin->meta->direct_subclasses], []); + +done_testing; diff --git a/t/cmop/subname.t b/t/cmop/subname.t new file mode 100644 index 0000000..6c113cc --- /dev/null +++ b/t/cmop/subname.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +{ + + package Origin; + sub bar { ( caller(0) )[3] } + + package Foo; +} + +my $Foo = Class::MOP::Class->initialize('Foo'); + +$Foo->add_method( foo => sub { ( caller(0) )[3] } ); + +is_deeply( + [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], + [ "Foo", "foo" ], + "subname applied to anonymous method", +); + +is( Foo->foo, "Foo::foo", "caller() aggrees" ); + +$Foo->add_method( bar => \&Origin::bar ); + +is( Origin->bar, "Origin::bar", "normal caller() operation in unrelated class" ); + +is_deeply( + [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], + [ "Foo", "foo" ], + "subname not applied if a name already exists", +); + +is( Foo->bar, "Origin::bar", "caller aggrees" ); + +is( Origin->bar, "Origin::bar", "unrelated class untouched" ); + +done_testing; diff --git a/t/cmop/universal_methods.t b/t/cmop/universal_methods.t new file mode 100644 index 0000000..0d3d646 --- /dev/null +++ b/t/cmop/universal_methods.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my $meta_class = Class::MOP::Class->create_anon_class; + +my %methods = map { $_->name => 1 } $meta_class->get_all_methods(); +my %method_names = map { $_ => 1 } $meta_class->get_all_method_names(); + +my @universal_methods = qw/isa can VERSION/; +push @universal_methods, 'DOES' if $] >= 5.010; + +for my $method (@universal_methods) { + ok( + $meta_class->find_method_by_name($method), + "find_method_by_name finds UNIVERSAL method $method" + ); + ok( + $meta_class->find_next_method_by_name($method), + "find_next_method_by_name finds UNIVERSAL method $method" + ); + ok( + scalar $meta_class->find_all_methods_by_name($method), + "find_all_methods_by_name finds UNIVERSAL method $method" + ); + ok( + $methods{$method}, + "get_all_methods includes $method from UNIVERSAL" + ); + ok( + $method_names{$method}, + "get_all_method_names includes $method from UNIVERSAL" + ); +} + +done_testing; diff --git a/t/compat/composite_metaroles.t b/t/compat/composite_metaroles.t new file mode 100644 index 0000000..3171624 --- /dev/null +++ b/t/compat/composite_metaroles.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; +} + +{ + package Parent; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { class => ['Foo::Role'] }, + ); +} + +{ + package Child; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { class => ['Foo::Role', 'Bar::Role'] }, + ); + ::is( ::exception { extends 'Parent' }, undef ); +} + +with_immutable { + isa_ok('Child', 'Parent'); + isa_ok(Child->meta, Parent->meta->_real_ref_name); + does_ok(Parent->meta, 'Foo::Role'); + does_ok(Child->meta, 'Foo::Role'); + does_ok(Child->meta, 'Bar::Role'); +} 'Parent', 'Child'; + +done_testing; diff --git a/t/compat/extends_nonmoose_that_isa_moose_with_metarole.t b/t/compat/extends_nonmoose_that_isa_moose_with_metarole.t new file mode 100644 index 0000000..db5e4b0 --- /dev/null +++ b/t/compat/extends_nonmoose_that_isa_moose_with_metarole.t @@ -0,0 +1,204 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP (); + +{ + package My::Role; + use Moose::Role; +} + +{ + package SomeClass; + use Moose -traits => 'My::Role'; +} + +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; +} + +{ + package SubSubClassUseBase; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'SubClassUseBase'; + }, undef, 'Can extend non-Moose class with parent class that is a Moose class with a meta role' ); +} + +{ + ok( SubSubClassUseBase->meta->meta->can('does_role') + && SubSubClassUseBase->meta->meta->does_role('My::Role'), + 'SubSubClassUseBase meta metaclass does the My::Role role' ); +} + +# Note, remove metaclasses of the 'use base' classes after each test, +# so that they have to be re-initialized - otherwise latter tests +# would not demonstrate the original issue. +Class::MOP::remove_metaclass_by_name('SubClassUseBase'); + +{ + package OtherClass; + use Moose; +} + +{ + package OtherSubClassUseBase; + use parent -norequire => 'OtherClass'; +} + +{ + package MultiParent1; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( SubClassUseBase OtherSubClassUseBase ); + }, undef, 'Can extend two non-Moose classes with parents that are different Moose metaclasses' ); +} + +{ + ok( MultiParent1->meta->meta->can('does_role') + && MultiParent1->meta->meta->does_role('My::Role'), + 'MultiParent1 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiParent2; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( OtherSubClassUseBase SubClassUseBase ); + }, undef, 'Can extend two non-Moose classes with parents that are different Moose metaclasses (reverse order)' ); +} + +{ + ok( MultiParent2->meta->meta->can('does_role') + && MultiParent2->meta->meta->does_role('My::Role'), + 'MultiParent2 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiParent3; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( OtherClass SubClassUseBase ); + }, undef, 'Can extend one Moose class and one non-Moose class' ); +} + +{ + ok( MultiParent3->meta->meta->can('does_role') + && MultiParent3->meta->meta->does_role('My::Role'), + 'MultiParent3 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiParent4; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( SubClassUseBase OtherClass ); + }, undef, 'Can extend one non-Moose class and one Moose class' ); +} + +{ + ok( MultiParent4->meta->meta->can('does_role') + && MultiParent4->meta->meta->does_role('My::Role'), + 'MultiParent4 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild1; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent1'; + }, undef, 'Can extend class that itself extends two non-Moose classes with Moose parents' ); +} + +{ + ok( MultiChild1->meta->meta->can('does_role') + && MultiChild1->meta->meta->does_role('My::Role'), + 'MultiChild1 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild2; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent2'; + }, undef, 'Can extend class that itself extends two non-Moose classes with Moose parents (reverse order)' ); +} + +{ + ok( MultiChild2->meta->meta->can('does_role') + && MultiChild2->meta->meta->does_role('My::Role'), + 'MultiChild2 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild3; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent3'; + }, undef, 'Can extend class that itself extends one Moose and one non-Moose parent' ); +} + +{ + ok( MultiChild3->meta->meta->can('does_role') + && MultiChild3->meta->meta->does_role('My::Role'), + 'MultiChild3 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild4; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent4'; + }, undef, 'Can extend class that itself extends one non-Moose and one Moose parent' ); +} + +{ + ok( MultiChild4->meta->meta->can('does_role') + && MultiChild4->meta->meta->does_role('My::Role'), + 'MultiChild4 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +done_testing; diff --git a/t/compat/foreign_inheritence.t b/t/compat/foreign_inheritence.t new file mode 100644 index 0000000..1d3b0d8 --- /dev/null +++ b/t/compat/foreign_inheritence.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Elk; + use strict; + use warnings; + + sub new { + my $class = shift; + bless { no_moose => "Elk" } => $class; + } + + sub no_moose { $_[0]->{no_moose} } + + package Foo::Moose; + use Moose; + + extends 'Elk'; + + has 'moose' => ( is => 'ro', default => 'Foo' ); + + sub new { + my $class = shift; + my $super = $class->SUPER::new(@_); + return $class->meta->new_object( '__INSTANCE__' => $super, @_ ); + } + + __PACKAGE__->meta->make_immutable( inline_constructor => 0, debug => 0 ); + + package Bucket; + use metaclass 'Class::MOP::Class'; + + __PACKAGE__->meta->add_attribute( + 'squeegee' => ( accessor => 'squeegee' ) ); + + package Old::Bucket::Nose; + + # see http://www.moosefoundation.org/moose_facts.htm + use Moose; + + extends 'Bucket'; + + package MyBase; + sub foo { } + + package Custom::Meta1; + use parent 'Moose::Meta::Class'; + + package Custom::Meta2; + use parent 'Moose::Meta::Class'; + + package SubClass1; + use metaclass 'Custom::Meta1'; + use Moose; + + extends 'MyBase'; + + package SubClass2; + use metaclass 'Custom::Meta2'; + use Moose; + + # XXX FIXME subclassing meta-attrs and immutable-ing the subclass fails +} + +my $foo_moose = Foo::Moose->new(); +isa_ok( $foo_moose, 'Foo::Moose' ); +isa_ok( $foo_moose, 'Elk' ); + +is( $foo_moose->no_moose, 'Elk', + '... got the right value from the Elk method' ); +is( $foo_moose->moose, 'Foo', + '... got the right value from the Foo::Moose method' ); + +is( exception { + Old::Bucket::Nose->meta->make_immutable( debug => 0 ); +}, undef, 'Immutability on Moose class extending Class::MOP class ok' ); + +is( exception { + SubClass2->meta->superclasses('MyBase'); +}, undef, 'Can subclass the same non-Moose class twice with different metaclasses' ); + +done_testing; diff --git a/t/compat/inc_hash.t b/t/compat/inc_hash.t new file mode 100644 index 0000000..25f6b47 --- /dev/null +++ b/t/compat/inc_hash.t @@ -0,0 +1,101 @@ +use strict; +use warnings; +use Test::More; +use lib 't/lib'; + +use Moose (); +use Module::Runtime 'module_notional_filename'; + +sub inc_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($class) = @_; + is($INC{module_notional_filename($class)}, '(set by Moose)'); +} + +sub no_inc_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($class) = @_; + ok(!exists $INC{module_notional_filename($class)}); +} + +{ + no_inc_ok('Foo'); + my $meta = Moose::Meta::Class->create('Foo'); + inc_ok('Foo'); +} +inc_ok('Foo'); + +{ + no_inc_ok('Bar'); + ok(!exists $INC{module_notional_filename('Bar')}); + my $meta = Class::MOP::Package->create('Bar'); + inc_ok('Bar'); +} +inc_ok('Bar'); + +my $anon_name; +{ + my $meta = Moose::Meta::Class->create_anon_class; + $anon_name = $meta->name; + inc_ok($anon_name); +} +no_inc_ok($anon_name); + +{ + no_inc_ok('Real::Package'); + require Real::Package; + like($INC{module_notional_filename('Real::Package')}, qr{t.lib.Real.Package\.pm$}); + my $meta = Moose::Meta::Class->create('Real::Package'); + like($INC{module_notional_filename('Real::Package')}, qr{t.lib.Real.Package\.pm$}); +} +like($INC{module_notional_filename('Real::Package')}, qr{t.lib.Real.Package\.pm$}); + +BEGIN { no_inc_ok('UseMoose') } +{ + package UseMoose; + use Moose; +} +BEGIN { inc_ok('UseMoose') } + +BEGIN { no_inc_ok('UseMooseRole') } +{ + package UseMooseRole; + use Moose::Role; +} +BEGIN { inc_ok('UseMooseRole') } + +BEGIN { + package My::Custom::Moose; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + ); + $INC{::module_notional_filename(__PACKAGE__)} = __FILE__; +} + +BEGIN { no_inc_ok('UseMooseCustom') } +{ + package UseMooseCustom; + use My::Custom::Moose; +} +BEGIN { inc_ok('UseMooseCustom') } + +BEGIN { + package My::Custom::Moose::Role; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose::Role'], + ); + $INC{::module_notional_filename(__PACKAGE__)} = __FILE__; +} + +BEGIN { no_inc_ok('UseMooseCustomRole') } +{ + package UseMooseCustomRole; + use My::Custom::Moose::Role; +} +BEGIN { inc_ok('UseMooseCustomRole') } + +done_testing; diff --git a/t/compat/module_refresh_compat.t b/t/compat/module_refresh_compat.t new file mode 100644 index 0000000..a3a627b --- /dev/null +++ b/t/compat/module_refresh_compat.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +use File::Spec; +use File::Temp 'tempdir'; + +use Test::Requires 'Module::Refresh'; # skip all if not installed + +=pod + +First lets test some of our simple example modules ... + +=cut + +my @modules = qw[Foo Bar MyMooseA MyMooseB MyMooseObject]; + +do { + use_ok($_); + + is($_->meta->name, $_, '... initialized the meta correctly'); + + is( exception { + Module::Refresh->new->refresh_module($_ . '.pm') + }, undef, '... successfully refreshed ' ); +} foreach @modules; + +=pod + +Now, lets try something a little trickier +and actually change the module itself. + +=cut + +my $dir = tempdir( "MooseTest-XXXXX", CLEANUP => 1, TMPDIR => 1 ); +push @INC, $dir; + +my $test_module_file = File::Spec->catdir($dir, 'TestBaz.pm'); + +my $test_module_source_1 = q| +package TestBaz; +use Moose; +has 'foo' => (is => 'ro', isa => 'Int'); +1; +|; + +my $test_module_source_2 = q| +package TestBaz; +use Moose; +extends 'Foo'; +has 'foo' => (is => 'rw', isa => 'Int'); +1; +|; + +{ + open FILE, ">", $test_module_file + || die "Could not open $test_module_file because $!"; + print FILE $test_module_source_1; + close FILE; +} + +use_ok('TestBaz'); +is(TestBaz->meta->name, 'TestBaz', '... initialized the meta correctly'); +ok(TestBaz->meta->has_attribute('foo'), '... it has the foo attribute as well'); +ok(!TestBaz->isa('Foo'), '... TestBaz is not a Foo'); + +{ + open FILE, ">", $test_module_file + || die "Could not open $test_module_file because $!"; + print FILE $test_module_source_2; + close FILE; +} + +is( exception { + Module::Refresh->new->refresh_module('TestBaz.pm') +}, undef, '... successfully refreshed ' ); + +is(TestBaz->meta->name, 'TestBaz', '... initialized the meta correctly'); +ok(TestBaz->meta->has_attribute('foo'), '... it has the foo attribute as well'); +ok(TestBaz->isa('Foo'), '... TestBaz is a Foo'); + +unlink $test_module_file; + +done_testing; diff --git a/t/compat/moose_respects_base.t b/t/compat/moose_respects_base.t new file mode 100644 index 0000000..84b9fda --- /dev/null +++ b/t/compat/moose_respects_base.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates that Moose will respect +a previously set @ISA using use base, and not +try to add Moose::Object to it. + +However, this is extremely order sensitive as +this test also demonstrates. + +=cut + +{ + package Foo; + use strict; + use warnings; + + sub foo { 'Foo::foo' } + + package Bar; + use parent -norequire => 'Foo'; + use Moose; + + sub new { (shift)->meta->new_object(@_) } + + package Baz; + use Moose; + use parent -norequire => 'Foo'; +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); +ok(!$bar->isa('Moose::Object'), '... Bar is not Moose::Object subclass'); + +my $baz = Baz->new; +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Moose::Object'); + +done_testing; diff --git a/t/examples/Child_Parent_attr_inherit.t b/t/examples/Child_Parent_attr_inherit.t new file mode 100644 index 0000000..c84cc25 --- /dev/null +++ b/t/examples/Child_Parent_attr_inherit.t @@ -0,0 +1,136 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +Some examples of triggers and how they can +be used to manage parent-child relationships. + +=cut + +{ + + package Parent; + use Moose; + + has 'last_name' => ( + is => 'rw', + isa => 'Str', + trigger => sub { + my $self = shift; + + # if the parents last-name changes + # then so do all the childrens + foreach my $child ( @{ $self->children } ) { + $child->last_name( $self->last_name ); + } + } + ); + + has 'children' => + ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); +} +{ + + package Child; + use Moose; + + has 'parent' => ( + is => 'rw', + isa => 'Parent', + required => 1, + trigger => sub { + my $self = shift; + + # if the parent is changed,.. + # make sure we update + $self->last_name( $self->parent->last_name ); + } + ); + + has 'last_name' => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { (shift)->parent->last_name } + ); + +} + +my $parent = Parent->new( last_name => 'Smith' ); +isa_ok( $parent, 'Parent' ); + +is( $parent->last_name, 'Smith', + '... the parent has the last name we expected' ); + +$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +$parent->last_name('Jones'); +is( $parent->last_name, 'Jones', '... the parent has the new last name' ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +# make a new parent + +my $parent2 = Parent->new( last_name => 'Brown' ); +isa_ok( $parent2, 'Parent' ); + +# orphan the child + +my $orphan = pop @{ $parent->children }; + +# and then the new parent adopts it + +$orphan->parent($parent2); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +isnt( $orphan->last_name, $parent->last_name, + '... the orphan child does not have the same last name anymore (' + . $parent2->last_name + . ')' ); +is( $orphan->last_name, $parent2->last_name, + '... parent2 and orphan child have the same last name (' + . $parent2->last_name + . ')' ); + +# make sure that changes still will not propagate + +$parent->last_name('Miller'); +is( $parent->last_name, 'Miller', + '... the parent has the new last name (again)' ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +isnt( $orphan->last_name, $parent->last_name, + '... the orphan child is not affected by changes in the parent anymore' ); +is( $orphan->last_name, $parent2->last_name, + '... parent2 and orphan child have the same last name (' + . $parent2->last_name + . ')' ); + +done_testing; diff --git a/t/examples/example1.t b/t/examples/example1.t new file mode 100644 index 0000000..643b0cd --- /dev/null +++ b/t/examples/example1.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; + + +## Roles + +{ + package Constraint; + use Moose::Role; + + has 'value' => (isa => 'Num', is => 'ro'); + + around 'validate' => sub { + my $c = shift; + my ($self, $field) = @_; + return undef if $c->($self, $self->validation_value($field)); + return $self->error_message; + }; + + sub validation_value { + my ($self, $field) = @_; + return $field; + } + + sub error_message { confess "Abstract method!" } + + package Constraint::OnLength; + use Moose::Role; + + has 'units' => (isa => 'Str', is => 'ro'); + + override 'validation_value' => sub { + return length(super()); + }; + + override 'error_message' => sub { + my $self = shift; + return super() . ' ' . $self->units; + }; + +} + +## Classes + +{ + package Constraint::AtLeast; + use Moose; + + with 'Constraint'; + + sub validate { + my ($self, $field) = @_; + ($field >= $self->value); + } + + sub error_message { 'must be at least ' . (shift)->value; } + + package Constraint::NoMoreThan; + use Moose; + + with 'Constraint'; + + sub validate { + my ($self, $field) = @_; + ($field <= $self->value); + } + + sub error_message { 'must be no more than ' . (shift)->value; } + + package Constraint::LengthNoMoreThan; + use Moose; + + extends 'Constraint::NoMoreThan'; + with 'Constraint::OnLength'; + + package Constraint::LengthAtLeast; + use Moose; + + extends 'Constraint::AtLeast'; + with 'Constraint::OnLength'; +} + +my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10); +isa_ok($no_more_than_10, 'Constraint::NoMoreThan'); + +ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint'); + +ok(!defined($no_more_than_10->validate(1)), '... validated correctly'); +is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly'); + +my $at_least_10 = Constraint::AtLeast->new(value => 10); +isa_ok($at_least_10, 'Constraint::AtLeast'); + +ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint'); + +ok(!defined($at_least_10->validate(11)), '... validated correctly'); +is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly'); + +# onlength + +my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars'); +isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan'); +isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan'); + +ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint'); +ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength'); + +ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly'); +is($no_more_than_10_chars->validate('foooooooooo'), + 'must be no more than 10 chars', + '... validation failed correctly'); + +my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars'); +isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast'); +isa_ok($at_least_10_chars, 'Constraint::AtLeast'); + +ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint'); +ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength'); + +ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly'); +is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly'); + +done_testing; diff --git a/t/examples/example2.t b/t/examples/example2.t new file mode 100644 index 0000000..fae26dd --- /dev/null +++ b/t/examples/example2.t @@ -0,0 +1,155 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +sub U { + my $f = shift; + sub { $f->($f, @_) }; +} + +sub Y { + my $f = shift; + U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->(); +} + +{ + package List; + use Moose::Role; + + has '_list' => ( + is => 'ro', + isa => 'ArrayRef', + init_arg => '::', + default => sub { [] } + ); + + sub head { (shift)->_list->[0] } + sub tail { + my $self = shift; + (ref $self)->new( + '::' => [ + @{$self->_list}[1 .. $#{$self->_list}] + ] + ); + } + + sub print { + join ", " => @{$_[0]->_list}; + } + + package List::Immutable; + use Moose::Role; + + requires 'head'; + requires 'tail'; + + sub is_empty { not defined ($_[0]->head) } + + sub length { + my $self = shift; + (::Y(sub { + my $redo = shift; + sub { + my ($list, $acc) = @_; + return $acc if $list->is_empty; + $redo->($list->tail, $acc + 1); + } + }))->($self, 0); + } + + sub apply { + my ($self, $function) = @_; + (::Y(sub { + my $redo = shift; + sub { + my ($list, $func, $acc) = @_; + return (ref $list)->new('::' => $acc) + if $list->is_empty; + $redo->( + $list->tail, + $func, + [ @{$acc}, $func->($list->head) ] + ); + } + }))->($self, $function, []); + } + + package My::List1; + use Moose; + + ::is( ::exception { + with 'List', 'List::Immutable'; + }, undef, '... successfully composed roles together' ); + + package My::List2; + use Moose; + + ::is( ::exception { + with 'List::Immutable', 'List'; + }, undef, '... successfully composed roles together' ); + +} + +{ + my $coll = My::List1->new; + isa_ok($coll, 'My::List1'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok($coll->is_empty, '... we have an empty collection'); + is($coll->length, 0, '... we have a length of 1 for the collection'); +} + +{ + my $coll = My::List2->new; + isa_ok($coll, 'My::List2'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok($coll->is_empty, '... we have an empty collection'); + is($coll->length, 0, '... we have a length of 1 for the collection'); +} + +{ + my $coll = My::List1->new('::' => [ 1 .. 10 ]); + isa_ok($coll, 'My::List1'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok(!$coll->is_empty, '... we do not have an empty collection'); + is($coll->length, 10, '... we have a length of 10 for the collection'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); + + my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); + isa_ok($coll2, 'My::List1'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); + is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); +} + +{ + my $coll = My::List2->new('::' => [ 1 .. 10 ]); + isa_ok($coll, 'My::List2'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok(!$coll->is_empty, '... we do not have an empty collection'); + is($coll->length, 10, '... we have a length of 10 for the collection'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); + + my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); + isa_ok($coll2, 'My::List2'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); + is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); +} + +done_testing; diff --git a/t/examples/example_Moose_POOP.t b/t/examples/example_Moose_POOP.t new file mode 100644 index 0000000..3da6a60 --- /dev/null +++ b/t/examples/example_Moose_POOP.t @@ -0,0 +1,428 @@ +use strict; +use warnings; + +use Test::More; + +use Test::Requires { + 'DBM::Deep' => '1.0003', # skip all if not installed + 'DateTime::Format::MySQL' => '0', +}; + +use Test::Fatal; + +BEGIN { + # in case there are leftovers + unlink('newswriter.db') if -e 'newswriter.db'; +} + +END { + unlink('newswriter.db') if -e 'newswriter.db'; +} + + +=pod + +This example creates a very basic Object Database which +links in the instances created with a backend store +(a DBM::Deep hash). It is by no means to be taken seriously +as a real-world ODB, but is a proof of concept of the flexibility +of the ::Instance protocol. + +=cut + +BEGIN { + + package MooseX::POOP::Meta::Instance; + use Moose; + + use DBM::Deep; + + extends 'Moose::Meta::Instance'; + + { + my %INSTANCE_COUNTERS; + + my $db = DBM::Deep->new({ + file => "newswriter.db", + autobless => 1, + locking => 1, + }); + + sub _reload_db { + #use Data::Dumper; + #warn Dumper $db; + $db = undef; + $db = DBM::Deep->new({ + file => "newswriter.db", + autobless => 1, + locking => 1, + }); + } + + sub create_instance { + my $self = shift; + my $class = $self->associated_metaclass->name; + my $oid = ++$INSTANCE_COUNTERS{$class}; + + $db->{$class}->[($oid - 1)] = {}; + + bless { + oid => $oid, + instance => $db->{$class}->[($oid - 1)] + }, $class; + } + + sub find_instance { + my ($self, $oid) = @_; + my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)]; + + bless { + oid => $oid, + instance => $instance, + }, $self->associated_metaclass->name; + } + + sub clone_instance { + my ($self, $instance) = @_; + + my $class = $self->{meta}->name; + my $oid = ++$INSTANCE_COUNTERS{$class}; + + my $clone = tied($instance)->clone; + + bless { + oid => $oid, + instance => $clone, + }, $class; + } + } + + sub get_instance_oid { + my ($self, $instance) = @_; + $instance->{oid}; + } + + sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + return $instance->{instance}->{$slot_name}; + } + + sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->{instance}->{$slot_name} = $value; + } + + sub is_slot_initialized { + my ($self, $instance, $slot_name, $value) = @_; + exists $instance->{instance}->{$slot_name} ? 1 : 0; + } + + sub weaken_slot_value { + confess "Not sure how well DBM::Deep plays with weak refs, Rob says 'Write a test'"; + } + + sub inline_slot_access { + my ($self, $instance, $slot_name) = @_; + sprintf "%s->{instance}->{%s}", $instance, $slot_name; + } + + package MooseX::POOP::Meta::Class; + use Moose; + + extends 'Moose::Meta::Class'; + + override '_construct_instance' => sub { + my $class = shift; + my $params = @_ == 1 ? $_[0] : {@_}; + return $class->get_meta_instance->find_instance($params->{oid}) + if $params->{oid}; + super(); + }; + +} +{ + package MooseX::POOP::Object; + use metaclass 'MooseX::POOP::Meta::Class' => ( + instance_metaclass => 'MooseX::POOP::Meta::Instance' + ); + use Moose; + + sub oid { + my $self = shift; + $self->meta + ->get_meta_instance + ->get_instance_oid($self); + } + +} +{ + package Newswriter::Author; + use Moose; + + extends 'MooseX::POOP::Object'; + + has 'first_name' => (is => 'rw', isa => 'Str'); + has 'last_name' => (is => 'rw', isa => 'Str'); + + package Newswriter::Article; + use Moose; + use Moose::Util::TypeConstraints; + + use DateTime::Format::MySQL; + + extends 'MooseX::POOP::Object'; + + subtype 'Headline' + => as 'Str' + => where { length($_) < 100 }; + + subtype 'Summary' + => as 'Str' + => where { length($_) < 255 }; + + subtype 'DateTimeFormatString' + => as 'Str' + => where { DateTime::Format::MySQL->parse_datetime($_) }; + + enum 'Status' => [qw(draft posted pending archive)]; + + has 'headline' => (is => 'rw', isa => 'Headline'); + has 'summary' => (is => 'rw', isa => 'Summary'); + has 'article' => (is => 'rw', isa => 'Str'); + + has 'start_date' => (is => 'rw', isa => 'DateTimeFormatString'); + has 'end_date' => (is => 'rw', isa => 'DateTimeFormatString'); + + has 'author' => (is => 'rw', isa => 'Newswriter::Author'); + + has 'status' => (is => 'rw', isa => 'Status'); + + around 'start_date', 'end_date' => sub { + my $c = shift; + my $self = shift; + $c->($self, DateTime::Format::MySQL->format_datetime($_[0])) if @_; + DateTime::Format::MySQL->parse_datetime($c->($self) || return undef); + }; +} + +{ # check the meta stuff first + isa_ok(MooseX::POOP::Object->meta, 'MooseX::POOP::Meta::Class'); + isa_ok(MooseX::POOP::Object->meta, 'Moose::Meta::Class'); + isa_ok(MooseX::POOP::Object->meta, 'Class::MOP::Class'); + + is(MooseX::POOP::Object->meta->instance_metaclass, + 'MooseX::POOP::Meta::Instance', + '... got the right instance metaclass name'); + + isa_ok(MooseX::POOP::Object->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); + + my $base = MooseX::POOP::Object->new; + isa_ok($base, 'MooseX::POOP::Object'); + isa_ok($base, 'Moose::Object'); + + isa_ok($base->meta, 'MooseX::POOP::Meta::Class'); + isa_ok($base->meta, 'Moose::Meta::Class'); + isa_ok($base->meta, 'Class::MOP::Class'); + + is($base->meta->instance_metaclass, + 'MooseX::POOP::Meta::Instance', + '... got the right instance metaclass name'); + + isa_ok($base->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); +} + +my $article_oid; +{ + my $article; + is( exception { + $article = Newswriter::Article->new( + headline => 'Home Office Redecorated', + summary => 'The home office was recently redecorated to match the new company colors', + article => '...', + + author => Newswriter::Author->new( + first_name => 'Truman', + last_name => 'Capote' + ), + + status => 'pending' + ); + }, undef, '... created my article successfully' ); + isa_ok($article, 'Newswriter::Article'); + isa_ok($article, 'MooseX::POOP::Object'); + + is( exception { + $article->start_date(DateTime->new(year => 2006, month => 6, day => 10)); + $article->end_date(DateTime->new(year => 2006, month => 6, day => 17)); + }, undef, '... add the article date-time stuff' ); + + ## check some meta stuff + + isa_ok($article->meta, 'MooseX::POOP::Meta::Class'); + isa_ok($article->meta, 'Moose::Meta::Class'); + isa_ok($article->meta, 'Class::MOP::Class'); + + is($article->meta->instance_metaclass, + 'MooseX::POOP::Meta::Instance', + '... got the right instance metaclass name'); + + isa_ok($article->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); + + ok($article->oid, '... got a oid for the article'); + + $article_oid = $article->oid; + + is($article->headline, + 'Home Office Redecorated', + '... got the right headline'); + is($article->summary, + 'The home office was recently redecorated to match the new company colors', + '... got the right summary'); + is($article->article, '...', '... got the right article'); + + isa_ok($article->start_date, 'DateTime'); + isa_ok($article->end_date, 'DateTime'); + + isa_ok($article->author, 'Newswriter::Author'); + is($article->author->first_name, 'Truman', '... got the right author first name'); + is($article->author->last_name, 'Capote', '... got the right author last name'); + + is($article->status, 'pending', '... got the right status'); +} + +MooseX::POOP::Meta::Instance->_reload_db(); + +my $article2_oid; +{ + my $article2; + is( exception { + $article2 = Newswriter::Article->new( + headline => 'Company wins Lottery', + summary => 'An email was received today that informed the company we have won the lottery', + article => 'WoW', + + author => Newswriter::Author->new( + first_name => 'Katie', + last_name => 'Couric' + ), + + status => 'posted' + ); + }, undef, '... created my article successfully' ); + isa_ok($article2, 'Newswriter::Article'); + isa_ok($article2, 'MooseX::POOP::Object'); + + $article2_oid = $article2->oid; + + is($article2->headline, + 'Company wins Lottery', + '... got the right headline'); + is($article2->summary, + 'An email was received today that informed the company we have won the lottery', + '... got the right summary'); + is($article2->article, 'WoW', '... got the right article'); + + ok(!$article2->start_date, '... these two dates are unassigned'); + ok(!$article2->end_date, '... these two dates are unassigned'); + + isa_ok($article2->author, 'Newswriter::Author'); + is($article2->author->first_name, 'Katie', '... got the right author first name'); + is($article2->author->last_name, 'Couric', '... got the right author last name'); + + is($article2->status, 'posted', '... got the right status'); + + ## orig-article + + my $article; + is( exception { + $article = Newswriter::Article->new(oid => $article_oid); + }, undef, '... (re)-created my article successfully' ); + isa_ok($article, 'Newswriter::Article'); + isa_ok($article, 'MooseX::POOP::Object'); + + is($article->oid, $article_oid, '... got a oid for the article'); + + is($article->headline, + 'Home Office Redecorated', + '... got the right headline'); + is($article->summary, + 'The home office was recently redecorated to match the new company colors', + '... got the right summary'); + is($article->article, '...', '... got the right article'); + + isa_ok($article->start_date, 'DateTime'); + isa_ok($article->end_date, 'DateTime'); + + isa_ok($article->author, 'Newswriter::Author'); + is($article->author->first_name, 'Truman', '... got the right author first name'); + is($article->author->last_name, 'Capote', '... got the right author last name'); + + is( exception { + $article->author->first_name('Dan'); + $article->author->last_name('Rather'); + }, undef, '... changed the value ok' ); + + is($article->author->first_name, 'Dan', '... got the changed author first name'); + is($article->author->last_name, 'Rather', '... got the changed author last name'); + + is($article->status, 'pending', '... got the right status'); +} + +MooseX::POOP::Meta::Instance->_reload_db(); + +{ + my $article; + is( exception { + $article = Newswriter::Article->new(oid => $article_oid); + }, undef, '... (re)-created my article successfully' ); + isa_ok($article, 'Newswriter::Article'); + isa_ok($article, 'MooseX::POOP::Object'); + + is($article->oid, $article_oid, '... got a oid for the article'); + + is($article->headline, + 'Home Office Redecorated', + '... got the right headline'); + is($article->summary, + 'The home office was recently redecorated to match the new company colors', + '... got the right summary'); + is($article->article, '...', '... got the right article'); + + isa_ok($article->start_date, 'DateTime'); + isa_ok($article->end_date, 'DateTime'); + + isa_ok($article->author, 'Newswriter::Author'); + is($article->author->first_name, 'Dan', '... got the changed author first name'); + is($article->author->last_name, 'Rather', '... got the changed author last name'); + + is($article->status, 'pending', '... got the right status'); + + my $article2; + is( exception { + $article2 = Newswriter::Article->new(oid => $article2_oid); + }, undef, '... (re)-created my article successfully' ); + isa_ok($article2, 'Newswriter::Article'); + isa_ok($article2, 'MooseX::POOP::Object'); + + is($article2->oid, $article2_oid, '... got a oid for the article'); + + is($article2->headline, + 'Company wins Lottery', + '... got the right headline'); + is($article2->summary, + 'An email was received today that informed the company we have won the lottery', + '... got the right summary'); + is($article2->article, 'WoW', '... got the right article'); + + ok(!$article2->start_date, '... these two dates are unassigned'); + ok(!$article2->end_date, '... these two dates are unassigned'); + + isa_ok($article2->author, 'Newswriter::Author'); + is($article2->author->first_name, 'Katie', '... got the right author first name'); + is($article2->author->last_name, 'Couric', '... got the right author last name'); + + is($article2->status, 'posted', '... got the right status'); + +} + +done_testing; diff --git a/t/examples/example_Protomoose.t b/t/examples/example_Protomoose.t new file mode 100644 index 0000000..59beadf --- /dev/null +++ b/t/examples/example_Protomoose.t @@ -0,0 +1,281 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This is an example of making Moose behave +more like a prototype based object system. + +Why? + +Well cause merlyn asked if it could :) + +=cut + +## ------------------------------------------------------------------ +## make some metaclasses + +{ + package ProtoMoose::Meta::Instance; + use Moose; + + BEGIN { extends 'Moose::Meta::Instance' }; + + # NOTE: + # do not let things be inlined by + # the attribute or accessor generator + sub is_inlinable { 0 } +} + +{ + package ProtoMoose::Meta::Method::Accessor; + use Moose; + + BEGIN { extends 'Moose::Meta::Method::Accessor' }; + + # customize the accessors to always grab + # the correct instance in the accessors + + sub find_instance { + my ($self, $candidate, $accessor_type) = @_; + + my $instance = $candidate; + my $attr = $self->associated_attribute; + + # if it is a class calling it ... + unless (blessed($instance)) { + # then grab the class prototype + $instance = $attr->associated_class->prototype_instance; + } + # if its an instance ... + else { + # and there is no value currently + # associated with the instance and + # we are trying to read it, then ... + if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) { + # again, defer the prototype in + # the class in which is was defined + $instance = $attr->associated_class->prototype_instance; + } + # otherwise, you want to assign + # to your local copy ... + } + return $instance; + } + + sub _generate_accessor_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { + if (scalar(@_) == 2) { + $attr->set_value( + $self->find_instance($_[0], 'w'), + $_[1] + ); + } + $attr->get_value($self->find_instance($_[0], 'r')); + }; + } + + sub _generate_reader_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $attr->get_value($self->find_instance($_[0], 'r')); + }; + } + + sub _generate_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { + $attr->set_value( + $self->find_instance($_[0], 'w'), + $_[1] + ); + }; + } + + # deal with these later ... + sub generate_predicate_method {} + sub generate_clearer_method {} + +} + +{ + package ProtoMoose::Meta::Attribute; + use Moose; + + BEGIN { extends 'Moose::Meta::Attribute' }; + + sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' } +} + +{ + package ProtoMoose::Meta::Class; + use Moose; + + BEGIN { extends 'Moose::Meta::Class' }; + + has 'prototype_instance' => ( + is => 'rw', + isa => 'Object', + predicate => 'has_prototypical_instance', + lazy => 1, + default => sub { (shift)->new_object } + ); + + sub initialize { + # NOTE: + # I am not sure why 'around' does + # not work here, have to investigate + # it later - SL + (shift)->SUPER::initialize(@_, + instance_metaclass => 'ProtoMoose::Meta::Instance', + attribute_metaclass => 'ProtoMoose::Meta::Attribute', + ); + } + + around '_construct_instance' => sub { + my $next = shift; + my $self = shift; + # NOTE: + # we actually have to do this here + # to tie-the-knot, if you take it + # out, then you get deep recursion + # several levels deep :) + $self->prototype_instance($next->($self, @_)) + unless $self->has_prototypical_instance; + return $self->prototype_instance; + }; + +} + +{ + package ProtoMoose::Object; + use metaclass 'ProtoMoose::Meta::Class'; + use Moose; + + sub new { + my $prototype = blessed($_[0]) + ? $_[0] + : $_[0]->meta->prototype_instance; + my (undef, %params) = @_; + my $self = $prototype->meta->clone_object($prototype, %params); + $self->BUILDALL(\%params); + return $self; + } +} + +## ------------------------------------------------------------------ +## make some classes now + +{ + package Foo; + use Moose; + + extends 'ProtoMoose::Object'; + + has 'bar' => (is => 'rw'); +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + has 'baz' => (is => 'rw'); +} + +## ------------------------------------------------------------------ + +## ------------------------------------------------------------------ +## Check that metaclasses are working/inheriting properly + +foreach my $class (qw/ProtoMoose::Object Foo Bar/) { + isa_ok($class->meta, + 'ProtoMoose::Meta::Class', + '... got the right metaclass for ' . $class . ' ->'); + + is($class->meta->instance_metaclass, + 'ProtoMoose::Meta::Instance', + '... got the right instance meta for ' . $class); + + is($class->meta->attribute_metaclass, + 'ProtoMoose::Meta::Attribute', + '... got the right attribute meta for ' . $class); +} + +## ------------------------------------------------------------------ + +# get the prototype for Foo +my $foo_prototype = Foo->meta->prototype_instance; +isa_ok($foo_prototype, 'Foo'); + +# set a value in the prototype +$foo_prototype->bar(100); +is($foo_prototype->bar, 100, '... got the value stored in the prototype'); + +# the "class" defers to the +# the prototype when asked +# about attributes +is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); + +# now make an instance, which +# is basically a clone of the +# prototype +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +# the instance is *not* the prototype +isnt($foo, $foo_prototype, '... got a new instance of Foo'); + +# but it has the same values ... +is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)'); + +# we can even change the values +# in the instance +$foo->bar(300); +is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)'); + +# and not change the one in the prototype +is($foo_prototype->bar, 100, '... got the value stored in the prototype'); +is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); + +## subclasses + +# now we can check that the subclass +# will seek out the correct prototypical +# value from its "parent" +is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)'); + +# we can then also set its local attrs +Bar->baz(50); +is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)'); + +# now we clone the Bar prototype +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +# and we see that we got the right values +# in the instance/clone +is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)'); +is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)'); + +# nowe we can change the value +$bar->bar(200); +is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)'); + +# and all our original and +# prototypical values are still +# the same +is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)'); +is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)'); +is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)'); + +done_testing; diff --git a/t/examples/example_w_DCS.t b/t/examples/example_w_DCS.t new file mode 100644 index 0000000..eb78d8d --- /dev/null +++ b/t/examples/example_w_DCS.t @@ -0,0 +1,87 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests how well Moose type constraints +play with Declare::Constraints::Simple. + +Pretty well if I do say so myself :) + +=cut + +use Test::Requires 'Declare::Constraints::Simple'; # skip all if not installed +use Test::Fatal; + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use Declare::Constraints::Simple -All; + + # define your own type ... + type( 'HashOfArrayOfObjects', + { + where => IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + ) + } ); + + has 'bar' => ( + is => 'rw', + isa => 'HashOfArrayOfObjects', + ); + + # inline the constraints as anon-subtypes + has 'baz' => ( + is => 'rw', + isa => subtype( { as => 'ArrayRef', where => IsArrayRef(IsInt) } ), + ); + + package Bar; + use Moose; +} + +my $hash_of_arrays_of_objs = { + foo1 => [ Bar->new ], + foo2 => [ Bar->new, Bar->new ], +}; + +my $array_of_ints = [ 1 .. 10 ]; + +my $foo; +is( exception { + $foo = Foo->new( + 'bar' => $hash_of_arrays_of_objs, + 'baz' => $array_of_ints, + ); +}, undef, '... construction succeeded' ); +isa_ok($foo, 'Foo'); + +is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly'); +is_deeply($foo->baz, $array_of_ints, '... got our value correctly'); + +isnt( exception { + $foo->bar([]); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->bar({ foo => 3 }); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->bar({ foo => [ 1, 2, 3 ] }); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->baz([ "foo" ]); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->baz({}); +}, undef, '... validation failed correctly' ); + +done_testing; diff --git a/t/examples/example_w_TestDeep.t b/t/examples/example_w_TestDeep.t new file mode 100644 index 0000000..caac9c6 --- /dev/null +++ b/t/examples/example_w_TestDeep.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests how well Moose type constraints +play with Test::Deep. + +Its not as pretty as Declare::Constraints::Simple, +but it is not completely horrid either. + +=cut + +use Test::Requires 'Test::Deep'; # skip all if not installed +use Test::Fatal; + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + use Test::Deep qw[ + eq_deeply array_each subhashof ignore + ]; + + # define your own type ... + type 'ArrayOfHashOfBarsAndRandomNumbers' + => where { + eq_deeply($_, + array_each( + subhashof({ + bar => Test::Deep::isa('Bar'), + random_number => ignore() + }) + ) + ) + }; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayOfHashOfBarsAndRandomNumbers', + ); + + package Bar; + use Moose; +} + +my $array_of_hashes = [ + { bar => Bar->new, random_number => 10 }, + { bar => Bar->new }, +]; + +my $foo; +is( exception { + $foo = Foo->new('bar' => $array_of_hashes); +}, undef, '... construction succeeded' ); +isa_ok($foo, 'Foo'); + +is_deeply($foo->bar, $array_of_hashes, '... got our value correctly'); + +isnt( exception { + $foo->bar({}); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->bar([{ foo => 3 }]); +}, undef, '... validation failed correctly' ); + +done_testing; diff --git a/t/examples/record_set_iterator.t b/t/examples/record_set_iterator.t new file mode 100644 index 0000000..fe432b4 --- /dev/null +++ b/t/examples/record_set_iterator.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Record; + use Moose; + + has 'first_name' => (is => 'ro', isa => 'Str'); + has 'last_name' => (is => 'ro', isa => 'Str'); + + package RecordSet; + use Moose; + + has 'data' => ( + is => 'ro', + isa => 'ArrayRef[Record]', + default => sub { [] }, + ); + + has 'index' => ( + is => 'rw', + isa => 'Int', + default => sub { 0 }, + ); + + sub next { + my $self = shift; + my $i = $self->index; + $self->index($i + 1); + return $self->data->[$i]; + } + + package RecordSetIterator; + use Moose; + + has 'record_set' => ( + is => 'rw', + isa => 'RecordSet', + ); + + # list the fields you want to + # fetch from the current record + my @fields = Record->meta->get_attribute_list; + + has 'current_record' => ( + is => 'rw', + isa => 'Record', + lazy => 1, + default => sub { + my $self = shift; + $self->record_set->next() # grab the first one + }, + trigger => sub { + my $self = shift; + # whenever this attribute is + # updated, it will clear all + # the fields for you. + $self->$_() for map { '_clear_' . $_ } @fields; + } + ); + + # define the attributes + # for all the fields. + for my $field (@fields) { + has $field => ( + is => 'ro', + isa => 'Any', + lazy => 1, + default => sub { + my $self = shift; + # fetch the value from + # the current record + $self->current_record->$field(); + }, + # make sure they have a clearer .. + clearer => ('_clear_' . $field) + ); + } + + sub get_next_record { + my $self = shift; + $self->current_record($self->record_set->next()); + } +} + +my $rs = RecordSet->new( + data => [ + Record->new(first_name => 'Bill', last_name => 'Smith'), + Record->new(first_name => 'Bob', last_name => 'Jones'), + Record->new(first_name => 'Jim', last_name => 'Johnson'), + ] +); +isa_ok($rs, 'RecordSet'); + +my $rsi = RecordSetIterator->new(record_set => $rs); +isa_ok($rsi, 'RecordSetIterator'); + +is($rsi->first_name, 'Bill', '... got the right first name'); +is($rsi->last_name, 'Smith', '... got the right last name'); + +$rsi->get_next_record; + +is($rsi->first_name, 'Bob', '... got the right first name'); +is($rsi->last_name, 'Jones', '... got the right last name'); + +$rsi->get_next_record; + +is($rsi->first_name, 'Jim', '... got the right first name'); +is($rsi->last_name, 'Johnson', '... got the right last name'); + +done_testing; diff --git a/t/exceptions/attribute.t b/t/exceptions/attribute.t new file mode 100644 index 0000000..600f51f --- /dev/null +++ b/t/exceptions/attribute.t @@ -0,0 +1,1194 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# tests for AccessorMustReadWrite +{ + use Moose; + + my $exception = exception { + has 'test' => ( + is => 'ro', + isa => 'Int', + accessor => 'bar', + ) + }; + + like( + $exception, + qr!Cannot define an accessor name on a read-only attribute, accessors are read/write!, + "Read-only attributes can't have accessor"); + + isa_ok( + $exception, + "Moose::Exception::AccessorMustReadWrite", + "Read-only attributes can't have accessor"); + + is( + $exception->attribute_name, + 'test', + "Read-only attributes can't have accessor"); +} + +# tests for AttributeIsRequired +{ + { + package Foo; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Int', + required => 1, + ); + } + + my $exception = exception { + Foo->new; + }; + + like( + $exception, + qr/\QAttribute (baz) is required/, + "... must supply all the required attribute"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "... must supply all the required attribute"); + + is( + $exception->attribute_name, + 'baz', + "... must supply all the required attribute"); + + isa_ok( + $exception->class_name, + 'Foo', + "... must supply all the required attribute"); +} + +# tests for invalid value for is +{ + my $exception = exception { + use Moose; + has 'foo' => ( + is => 'bar', + ); + }; + + like( + $exception, + qr/^\QI do not understand this option (is => bar) on attribute (foo)/, + "invalid value for is"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidValueForIs', + "invalid value for is"); +} + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Foo', + does => 'Not::A::Role' + ); + }; + + like( + $exception, + qr/^\QCannot have an isa option and a does option if the isa does not do the does on attribute (bar)/, + "isa option should does the role on the given attribute"); + + isa_ok( + $exception, + 'Moose::Exception::IsaDoesNotDoTheRole', + "isa option should does the role on the given attribute"); +} + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + has 'bar' => ( + is => 'ro', + isa => 'Not::A::Class', + does => 'Not::A::Role', + ); + }; + + like( + $exception, + qr/^\QCannot have an isa option which cannot ->does() on attribute (bar)/, + "isa option which is not a class cannot ->does the role specified in does"); + + isa_ok( + $exception, + 'Moose::Exception::IsaLacksDoesMethod', + "isa option which is not a class cannot ->does the role specified in does"); +} + +{ + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + coerce => 1, + ); + }; + + like( + $exception, + qr/^\QYou cannot have coercion without specifying a type constraint on attribute (bar)/, + "cannot coerce if type constraint i.e. isa option is not given"); + + isa_ok( + $exception, + 'Moose::Exception::CoercionNeedsTypeConstraint', + "cannot coerce if type constraint i.e. isa option is not given"); +} + +{ + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + weak_ref => 1, + coerce => 1, + ); + }; + + like( + $exception, + qr/^\QYou cannot have a weak reference to a coerced value on attribute (bar)/, + "cannot coerce if attribute is a weak_ref"); + + isa_ok( + $exception, + 'Moose::Exception::CannotCoerceAWeakRef', + "cannot coerce if attribute is a weak_ref"); +} + +{ + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + trigger => "foo", + ); + }; + + like( + $exception, + qr/^\QTrigger must be a CODE ref on attribute (bar)/, + "Trigger must be a CODE ref"); + + isa_ok( + $exception, + 'Moose::Exception::TriggerMustBeACodeRef', + "Trigger must be a CODE ref"); +} + +{ + { + package Foo; + use Moose; + has 'baz' => ( + is => 'ro', + isa => 'Int', + builder => "_build_baz", + ); + } + + my $exception = exception { + Foo->new; + }; + + like( + $exception, + qr/^\QFoo does not support builder method '_build_baz' for attribute 'baz'/, + "Correct error when a builder method is not present"); + + isa_ok( + $exception, + 'Moose::Exception::BuilderDoesNotExist', + "Correct error when a builder method is not present"); + + isa_ok( + $exception->instance, + 'Foo', + "Correct error when a builder method is not present"); + + is( + $exception->attribute->name, + 'baz', + "Correct error when a builder method is not present"); + + is( + $exception->attribute->builder, + '_build_baz', + "Correct error when a builder method is not present"); +} + +# tests for CannotDelegateWithoutIsa +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + handles => qr/baz/, + ); + }; + + like( + $exception, + qr/\QCannot delegate methods based on a Regexp without a type constraint (isa)/, + "isa is required while delegating methods based on a Regexp"); + + isa_ok( + $exception, + 'Moose::Exception::CannotDelegateWithoutIsa', + "isa is required while delegating methods based on a Regexp"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has bar => ( + is => 'ro', + auto_deref => 1, + ); + }; + + like( + $exception, + qr/\QYou cannot auto-dereference without specifying a type constraint on attribute (bar)/, + "You cannot auto-dereference without specifying a type constraint on attribute"); + + isa_ok( + $exception, + 'Moose::Exception::CannotAutoDerefWithoutIsa', + "You cannot auto-dereference without specifying a type constraint on attribute"); + + is( + $exception->attribute_name, + 'bar', + "You cannot auto-dereference without specifying a type constraint on attribute"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + required => 1, + init_arg => undef, + ); + }; + + like( + $exception, + qr/\QYou cannot have a required attribute (bar) without a default, builder, or an init_arg/, + "No default, builder or init_arg is given"); + + isa_ok( + $exception, + 'Moose::Exception::RequiredAttributeNeedsADefault', + "No default, builder or init_arg is given"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + lazy => 1, + ); + }; + + like( + $exception, + qr/\QYou cannot have a lazy attribute (bar) without specifying a default value for it/, + "No default for a lazy attribute is given"); + + isa_ok( + $exception, + 'Moose::Exception::LazyAttributeNeedsADefault', + "No default for a lazy attribute is given"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + auto_deref => 1, + ); + }; + + like( + $exception, + qr/\QYou cannot auto-dereference anything other than a ArrayRef or HashRef on attribute (bar)/, + "auto_deref needs either HashRef or ArrayRef"); + + isa_ok( + $exception, + 'Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef', + "auto_deref needs either HashRef or ArrayRef"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + lazy_build => 1, + default => 1, + ); + }; + + like( + $exception, + qr/\QYou can not use lazy_build and default for the same attribute (bar)/, + "An attribute can't use lazy_build & default simultaneously"); + + isa_ok( + $exception, + 'Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously', + "An attribute can't use lazy_build & default simultaneously"); +} + +{ + my $exception = exception { + package Delegator; + use Moose; + + sub full { 1 } + sub stub; + + has d1 => ( + isa => 'X', + handles => ['full'], + ); + }; + + like( + $exception, + qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, + 'got an error when trying to declare a delegation method that overwrites a local method'); + + isa_ok( + $exception, + 'Moose::Exception::CannotDelegateLocalMethodIsPresent', + "got an error when trying to declare a delegation method that overwrites a local method"); + + $exception = exception { + package Delegator; + use Moose; + + has d2 => ( + isa => 'X', + handles => ['stub'], + ); + }; + + is( + $exception, + undef, + 'no error when trying to declare a delegation method that overwrites a stub method'); +} + +{ + { + package Test; + use Moose; + has 'foo' => ( + is => 'rw', + clearer => 'clear_foo', + predicate => 'foo', + accessor => 'bar', + ); + } + + my $exception = exception { + package Test2; + use Moose; + extends 'Test'; + has '+foo' => ( + clearer => 'clear_foo1', + ); + }; + + like( + $exception, + qr/\QIllegal inherited options => (clearer)/, + "Illegal inherited option is given"); + + isa_ok( + $exception, + "Moose::Exception::IllegalInheritedOptions", + "Illegal inherited option is given"); + + $exception = exception { + package Test3; + use Moose; + extends 'Test'; + has '+foo' => ( + clearer => 'clear_foo1', + predicate => 'xyz', + accessor => 'bar2', + ); + }; + + like( + $exception, + qr/\QIllegal inherited options => (accessor, clearer, predicate)/, + "Illegal inherited option is given"); +} + +# tests for exception thrown is Moose::Meta::Attribute::set_value +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + required => 1, + ); + } + + my $instance = Foo1->new(bar => "test"); + my $bar_attr = Foo1->meta->get_attribute('bar'); + my $bar_writer = $bar_attr->get_write_method_ref; + $bar_writer->($instance); + }; + + like( + $exception, + qr/\QAttribute (bar) is required/, + "... must supply all the required attribute"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "... must supply all the required attribute"); + + is( + $exception->attribute_name, + 'bar', + "... must supply all the required attribute"); + + isa_ok( + $exception->class_name, + 'Foo1', + "... must supply all the required attribute"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + handles => \*STDIN, + ); + } + }; + + my $handle = \*STDIN; + + like( + $exception, + qr/\QUnable to canonicalize the 'handles' option with $handle/, + "handles doesn't take file handle"); + #Unable to canonicalize the 'handles' option with GLOB(0x109d0b0) + + isa_ok( + $exception, + "Moose::Exception::UnableToCanonicalizeHandles", + "handles doesn't take file handle"); + +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + handles => 'Foo1', + ); + } + }; + + like( + $exception, + qr/\QUnable to canonicalize the 'handles' option with Foo1 because its metaclass is not a Moose::Meta::Role/, + "'Str' given to handles should be a metaclass of Moose::Meta::Role"); + + isa_ok( + $exception, + "Moose::Exception::UnableToCanonicalizeNonRolePackage", + "'Str' given to handles should be a metaclass of Moose::Meta::Role"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Not::Loaded', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a class which has not been loaded - Not::Loaded/, + "You cannot delegate to a class which has not yet loaded"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToAClassWhichIsNotLoaded", + "You cannot delegate to a class which has not yet loaded"); + + is( + $exception->attribute->name, + 'bar', + "You cannot delegate to a class which has not yet loaded" + ); + + is( + $exception->class_name, + 'Not::Loaded', + "You cannot delegate to a class which has not yet loaded" + ); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has bar => ( + is => 'ro', + does => 'Role', + handles => qr/Role/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a role which has not been loaded - Role/, + "You cannot delegate to a role which has not yet loaded"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToARoleWhichIsNotLoaded", + "You cannot delegate to a role which has not yet loaded"); + + is( + $exception->attribute->name, + 'bar', + "You cannot delegate to a role which has not yet loaded" + ); + + is( + $exception->role_name, + 'Role', + "You cannot delegate to a role which has not yet loaded" + ); +} + + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a type (Int) that is not backed by a class/, + "Delegating to a type that is not backed by a class"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToATypeWhichIsNotAClass", + "Delegating to a type that is not backed by a class"); + + is( + $exception->attribute->name, + 'bar', + "Delegating to a type that is not backed by a class"); + + is( + $exception->attribute->type_constraint->name, + 'Int', + "Delegating to a type that is not backed by a class"); + + $exception = exception { + { + package Foo1; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'PositiveInt', + as 'Int', + where { $_ > 0 }; + + has 'bar' => ( + is => 'ro', + isa => 'PositiveInt', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a type (PositiveInt) that is not backed by a class/, + "Delegating to a type that is not backed by a class"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToATypeWhichIsNotAClass", + "Delegating to a type that is not backed by a class"); + + is( + $exception->attribute->type_constraint->name, + 'PositiveInt', + "Delegating to a type that is not backed by a class"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + does => '', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/Cannot find delegate metaclass for attribute bar/, + "no does or isa is given"); + + isa_ok( + $exception, + "Moose::Exception::CannotFindDelegateMetaclass", + "no does or isa is given"); + + is( + $exception->attribute->name, + 'bar', + "no does or isa is given"); +} + +# tests for type coercions +{ + use Moose; + use Moose::Util::TypeConstraints; + subtype 'HexNum' => as 'Int', where { /[a-f0-9]/i }; + my $type_object = find_type_constraint 'HexNum'; + + my $exception = exception { + $type_object->coerce; + }; + + like( + $exception, + qr/Cannot coerce without a type coercion/, + "You cannot coerce a type unless coercion is supported by that type"); + + isa_ok( + $exception, + "Moose::Exception::CoercingWithoutCoercions", + "You cannot coerce a type unless coercion is supported by that type"); + + is( + $exception->type_name, + 'HexNum', + "You cannot coerce a type unless coercion is supported by that type"); +} + +{ + { + package Parent; + use Moose; + + has foo => ( + is => 'rw', + isa => 'Num', + default => 5.5, + ); + } + + { + package Child; + use Moose; + extends 'Parent'; + + has '+foo' => ( + isa => 'Int', + default => 100, + ); + } + + my $foo = Child->new; + my $exception = exception { + $foo->foo(10.5); + }; + + like( + $exception, + qr/\QAttribute (foo) does not pass the type constraint because: Validation failed for 'Int' with value 10.5/, + "10.5 is not an Int"); + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + "10.5 is not an Int"); + + is( + $exception->class_name, + "Child", + "10.5 is not an Int"); +} + +{ + { + package Foo2; + use Moose; + + has a4 => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => 'invalid', + clearer => '_clear_a4', + handles => { + get_a4 => 'get', + push_a4 => 'push', + accessor_a4 => 'accessor', + }, + ); + + has a5 => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef[Int]', + lazy => 1, + default => sub { [] }, + clearer => '_clear_a5', + handles => { + get_a5 => 'get', + push_a5 => 'push', + accessor_a5 => 'accessor', + }, + ); + } + + my $foo = Foo2->new; + + my $expect + = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/; + + my $exception = exception { $foo->accessor_a4(0); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to read via accessor'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to read via accessor'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to read via accessor'); + + $exception = exception { $foo->accessor_a4( 0 => 42 ); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to write via accessor'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to write via accessor'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to write via accessor'); + + $exception = exception { $foo->push_a4(42); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to push'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to push'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to push'); + + $exception = exception { $foo->get_a4(42); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to get'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to get'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to get'); +} + +{ + my $class = Moose::Meta::Class->create("RedundantClass"); + my $attr = Moose::Meta::Attribute->new('foo', (auto_deref => 1, + isa => 'ArrayRef', + is => 'ro' + ) + ); + my $attr2 = $attr->clone_and_inherit_options( isa => 'Int'); + + my $exception = exception { + $attr2->get_value($class); + }; + + like( + $exception, + qr/Can not auto de-reference the type constraint 'Int'/, + "Cannot auto-deref with 'Int'"); + + isa_ok( + $exception, + "Moose::Exception::CannotAutoDereferenceTypeConstraint", + "Cannot auto-deref with 'Int'"); + + is( + $exception->attribute->name, + "foo", + "Cannot auto-deref with 'Int'"); + + is( + $exception->type_name, + "Int", + "Cannot auto-deref with 'Int'"); +} + +{ + { + my $parameterizable = subtype 'ParameterizableArrayRef', as 'ArrayRef'; + my $int = find_type_constraint('Int'); + my $from_parameterizable = $parameterizable->parameterize($int); + + { + package Parameterizable; + use Moose; + + has from_parameterizable => ( is => 'rw', isa => $from_parameterizable ); + } + } + + my $params = Parameterizable->new(); + my $exception = exception { + $params->from_parameterizable( 'Hello' ); + }; + + like( + $exception, + qr/\QAttribute (from_parameterizable) does not pass the type constraint because: Validation failed for 'ParameterizableArrayRef[Int]'\E with value "?Hello"?/, + "'Hello' is a Str"); + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + "'Hello' is a Str"); + + is( + $exception->class_name, + "Parameterizable", + "'Hello' is a Str"); + + is( + $exception->value, + "Hello", + "'Hello' is a Str"); + + is( + $exception->attribute_name, + "from_parameterizable", + "'Hello' is a Str"); +} + +{ + { + package Test::LazyBuild::Attribute; + use Moose; + + has 'fool' => ( lazy_build => 1, is => 'ro'); + } + + my $instance = Test::LazyBuild::Attribute->new; + + my $exception = exception { + $instance->fool; + }; + + like( + $exception, + qr/\QTest::LazyBuild::Attribute does not support builder method '_build_fool' for attribute 'fool' /, + "builder method _build_fool doesn't exist"); + + isa_ok( + $exception, + "Moose::Exception::BuilderMethodNotSupportedForInlineAttribute", + "builder method _build_fool doesn't exist"); + + is( + $exception->attribute_name, + "fool", + "builder method _build_fool doesn't exist"); + + is( + $exception->builder, + "_build_fool", + "builder method _build_fool doesn't exist"); + + is( + $exception->class_name, + "Test::LazyBuild::Attribute", + "builder method _build_fool doesn't exist"); +} + +{ + { + package Foo::Required; + use Moose; + + has 'foo_required' => ( + reader => 'get_foo_required', + writer => 'set_foo_required', + required => 1, + ); + } + + my $foo = Foo::Required->new(foo_required => "required"); + + my $exception = exception { + $foo->set_foo_required(); + }; + + like( + $exception, + qr/\QAttribute (foo_required) is required/, + "passing no value to set_foo_required"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "passing no value to set_foo_required"); + + is( + $exception->attribute_name, + 'foo_required', + "passing no value to set_foo_required"); + + isa_ok( + $exception->class_name, + 'Foo::Required', + "passing no value to set_foo_required"); +} + +{ + use Moose::Util::TypeConstraints; + + my $exception = exception { + { + package BadMetaClass; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => "Moose::Util::TypeConstraints", + handles => qr/hello/ + ); + } + }; + + like( + $exception, + qr/Unable to recognize the delegate metaclass 'Class::MOP::Package/, + "unable to recognize metaclass of Moose::Util::TypeConstraints"); + + isa_ok( + $exception, + "Moose::Exception::UnableToRecognizeDelegateMetaclass", + "unable to recognize metaclass of Moose::Util::TypeConstraints"); + + is( + $exception->attribute->name, + 'foo', + "unable to recognize metaclass of Moose::Util::TypeConstraints"); + + is( + $exception->delegate_metaclass->name, + 'Moose::Util::TypeConstraints', + "unable to recognize metaclass of Moose::Util::TypeConstraints"); +} + +{ + my $exception = exception { + package Foo::CannotCoerce::WithoutCoercion; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + coerce => 1 + ) + }; + + like( + $exception, + qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/, + "has throws error with odd number of attribute options"); + + isa_ok( + $exception, + "Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion", + "has throws error with odd number of attribute options"); + + is( + $exception->attribute_name, + 'foo', + "has throws error with odd number of attribute options"); + + is( + $exception->type_name, + 'Str', + "has throws error with odd number of attribute options"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => + ); + } + }; + + like( + $exception, + qr/\QYou must pass an even number of attribute options/, + 'has throws exception with odd number of attribute options'); + + isa_ok( + $exception, + "Moose::Exception::MustPassEvenNumberOfAttributeOptions", + 'has throws exception with odd number of attribute options'); + + is( + $exception->attribute_name, + 'bar', + 'has throws exception with odd number of attribute options'); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has bar => ( + is => 'ro', + required => 1, + isa => 'Int', + ); + } + + Foo1->new(bar => "test"); + }; + + like( + $exception, + qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Int' with value "?test"?/, + "bar is an 'Int' and 'Str' is given"); + #Attribute (bar) does not pass the type constraint because: Validation failed for 'Int' with value "test" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForTypeConstraint", + "bar is an 'Int' and 'Str' is given"); +} + +done_testing; diff --git a/t/exceptions/class-mop-attribute.t b/t/exceptions/class-mop-attribute.t new file mode 100644 index 0000000..d710699 --- /dev/null +++ b/t/exceptions/class-mop-attribute.t @@ -0,0 +1,213 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $class = Class::MOP::Attribute->new; + }; + + like( + $exception, + qr/You must provide a name for the attribute/, + "no attribute name given to new"); + + isa_ok( + $exception, + "Moose::Exception::MOPAttributeNewNeedsAttributeName", + "no attribute name given to new"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( builder => [123] )); + }; + + like( + $exception, + qr/builder must be a defined scalar value which is a method name/, + "an array ref is given as builder"); + + isa_ok( + $exception, + "Moose::Exception::BuilderMustBeAMethodName", + "an array ref is given as builder"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( builder => "bar", default => "xyz" )); + }; + + like( + $exception, + qr/\QSetting both default and builder is not allowed./, + "builder & default, both are given"); + + isa_ok( + $exception, + "Moose::Exception::BothBuilderAndDefaultAreNotAllowed", + "builder & default, both are given"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( default => [1] ) ); + }; + + like( + $exception, + qr/\QReferences are not allowed as default values, you must wrap the default of 'foo' in a CODE reference (ex: sub { [] } and not [])/, + "default value can't take references"); + + isa_ok( + $exception, + "Moose::Exception::ReferencesAreNotAllowedAsDefault", + "default value can't take references"); + + is( + $exception->attribute_name, + "foo", + "default value can't take references"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( required => 1, init_arg => undef ) ); + }; + + like( + $exception, + qr/A required attribute must have either 'init_arg', 'builder', or 'default'/, + "no 'init_arg', 'builder' or 'default' is given"); + + isa_ok( + $exception, + "Moose::Exception::RequiredAttributeLacksInitialization", + "no 'init_arg', 'builder' or 'default' is given"); +} + +{ + my $exception = exception { + my $foo = Class::MOP::Attribute->new("bar", ( required => 1, init_arg => undef, builder => 'foo')); + $foo->initialize_instance_slot( $foo->meta, $foo ); + }; + + like( + $exception, + qr/\QClass::MOP::Attribute does not support builder method 'foo' for attribute 'bar'/, + "given builder method doesn't exist"); + + isa_ok( + $exception, + "Moose::Exception::BuilderMethodNotSupportedForAttribute", + "given builder method doesn't exist"); + + is( + $exception->attribute->name, + "bar", + "given builder method doesn't exist"); + + is( + $exception->attribute->builder, + "foo", + "given builder method doesn't exist"); +} + +{ + my $exception = exception { + my $foo = Class::MOP::Attribute->new("foo"); + $foo->attach_to_class( "Foo" ); + }; + + like( + $exception, + qr/\QYou must pass a Class::MOP::Class instance (or a subclass)/, + "attach_to_class expects an instance Class::MOP::Class or its subclass"); + + isa_ok( + $exception, + "Moose::Exception::AttachToClassNeedsAClassMOPClassInstanceOrASubclass", + "attach_to_class expects an instance Class::MOP::Class or its subclass"); + + is( + $exception->attribute->name, + "foo", + "attach_to_class expects an instance Class::MOP::Class or its subclass"); + + is( + $exception->class, + "Foo", + "attach_to_class expects an instance Class::MOP::Class or its subclass"); +} + +{ + my $array = ["foo"]; + my $bar = Class::MOP::Attribute->new("bar", ( is => 'ro', predicate => $array)); + my $exception = exception { + $bar->install_accessors; + }; + + like( + $exception, + qr!bad accessor/reader/writer/predicate/clearer format, must be a HASH ref!, + "an array reference is given to predicate"); + + isa_ok( + $exception, + "Moose::Exception::BadOptionFormat", + "an array reference is given to predicate"); + + is( + $exception->attribute->name, + "bar", + "an array reference is given to predicate"); + + is( + $exception->option_name, + "predicate", + "an array reference is given to predicate"); + + is( + $exception->option_value, + $array, + "an array reference is given to predicate"); +} + +{ + my $bar = Class::MOP::Attribute->new("bar", ( is => 'ro', predicate => "foo")); + my $exception = exception { + $bar->install_accessors; + }; + + like( + $exception, + qr/\QCould not create the 'predicate' method for bar because : Can't call method "name" on an undefined value/, + "Can't call method 'name' on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotCreateMethod", + "Can't call method 'name' on an undefined value"); + + is( + $exception->attribute->name, + "bar", + "Can't call method 'name' on an undefined value"); + + is( + $exception->option_name, + "predicate", + "Can't call method 'name' on an undefined value"); + + is( + $exception->option_value, + "foo", + "Can't call method 'name' on an undefined value"); +} + +done_testing; diff --git a/t/exceptions/class-mop-class-immutable-trait.t b/t/exceptions/class-mop-class-immutable-trait.t new file mode 100644 index 0000000..abefba7 --- /dev/null +++ b/t/exceptions/class-mop-class-immutable-trait.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; + __PACKAGE__->meta->superclasses("Bar"); + }; + + like( + $exception, + qr/The 'superclasses' method is read-only when called on an immutable instance/, + "calling 'foo' on an immutable instance"); + + isa_ok( + $exception, + "Moose::Exception::CallingReadOnlyMethodOnAnImmutableInstance", + "calling 'foo' on an immutable instance"); + + is( + $exception->method_name, + "superclasses", + "calling 'foo' on an immutable instance"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; + __PACKAGE__->meta->add_method( foo => sub { "foo" } ); + }; + + like( + $exception, + qr/The 'add_method' method cannot be called on an immutable instance/, + "calling 'add_method' on an immutable instance"); + + isa_ok( + $exception, + "Moose::Exception::CallingMethodOnAnImmutableInstance", + "calling 'add_method' on an immutable instance"); + + is( + $exception->method_name, + "add_method", + "calling 'add_method' on an immutable instance"); +} + +done_testing; diff --git a/t/exceptions/class-mop-class.t b/t/exceptions/class-mop-class.t new file mode 100644 index 0000000..7e4a447 --- /dev/null +++ b/t/exceptions/class-mop-class.t @@ -0,0 +1,685 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $class = Class::MOP::Class::initialize; + }; + + like( + $exception, + qr/You must pass a package name and it cannot be blessed/, + "no package name given to initialize"); + + isa_ok( + $exception, + "Moose::Exception::InitializeTakesUnBlessedPackageName", + "no package name given to initialize"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class::create("Foo" => ( superclasses => ('foo') )); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of superclasses/, + "an Array is of superclasses is passed"); + + isa_ok( + $exception, + "Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses", + "an Array is of superclasses is passed"); + + is( + $exception->class, + 'Foo', + "an Array is of superclasses is passed"); +} + + +{ + my $exception = exception { + my $class = Class::MOP::Class::create("Foo" => ( attributes => ('foo') )); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of attributes/, + "an Array is of attributes is passed"); + + isa_ok( + $exception, + "Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes", + "an Array is of attributes is passed"); + + is( + $exception->class, + 'Foo', + "an Array is of attributes is passed"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class::create("Foo" => ( methods => ('foo') ) ); + }; + + like( + $exception, + qr/You must pass an HASH ref of methods/, + "a Hash is of methods is passed"); + + isa_ok( + $exception, + "Moose::Exception::CreateMOPClassTakesHashRefOfMethods", + "a Hash is of methods is passed"); + + is( + $exception->class, + 'Foo', + "a Hash is of methods is passed"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->create("Foo"); + $class->find_method_by_name; + }; + + like( + $exception, + qr/You must define a method name to find/, + "no method name given to find_method_by_name"); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotGiven", + "no method name given to find_method_by_name"); + + is( + $exception->class_name, + 'Foo', + "no method name given to find_method_by_name"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->create("Foo"); + $class->find_all_methods_by_name; + }; + + like( + $exception, + qr/You must define a method name to find/, + "no method name given to find_all_methods_by_name"); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotGiven", + "no method name given to find_all_methods_by_name"); + + is( + $exception->class_name, + 'Foo', + "no method name given to find_all_methods_by_name"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->create("Foo"); + $class->find_next_method_by_name; + }; + + like( + $exception, + qr/You must define a method name to find/, + "no method name given to find_next_method_by_name"); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotGiven", + "no method name given to find_next_method_by_name"); + + is( + $exception->class_name, + 'Foo', + "no method name given to find_next_method_by_name"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $foo = "foo"; + my $exception = exception { + $class->clone_object( $foo ); + }; + + like( + $exception, + qr/\QYou must pass an instance of the metaclass (Foo), not (foo)/, + "clone_object expects an instance of the metaclass"); + + isa_ok( + $exception, + "Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass", + "clone_object expects an instance of the metaclass"); + + is( + $exception->class_name, + 'Foo', + "clone_object expects an instance of the metaclass"); + + is( + $exception->instance, + 'foo', + "clone_object expects an instance of the metaclass"); +} + +{ + { + package Foo; + use Moose; + } + { + package Foo2; + use Moose; + } + my $foo2 = Foo2->new; + my $exception = exception { + Foo->meta->rebless_instance( $foo2 ); + }; + + like( + $exception, + qr/\QYou may rebless only into a subclass of (Foo2), of which (Foo) isn't./, + "you can rebless only into subclass"); + + isa_ok( + $exception, + "Moose::Exception::CanReblessOnlyIntoASubclass", + "you can rebless only into subclass"); + + is( + $exception->class_name, + 'Foo', + "you can rebless only into subclass"); + + is( + $exception->instance, + $foo2, + "you can rebless only into subclass"); +} + +{ + { + package Foo; + use Moose; + } + { + package Foo2; + use Moose; + } + my $foo = Foo->new; + my $exception = exception { + Foo2->meta->rebless_instance_back( $foo ); + }; + + like( + $exception, + qr/\QYou may rebless only into a superclass of (Foo), of which (Foo2) isn't./, + "you can rebless only into superclass"); + + isa_ok( + $exception, + "Moose::Exception::CanReblessOnlyIntoASuperclass", + "you can rebless only into superclass"); + + is( + $exception->instance, + $foo, + "you can rebless only into superclass"); + + is( + $exception->class_name, + "Foo2", + "you can rebless only into superclass"); +} + +{ + { + package Foo; + use Moose; + } + my $exception = exception { + Foo->meta->add_before_method_modifier; + }; + + like( + $exception, + qr/You must pass in a method name/, + "no method name passed to method modifier"); + + isa_ok( + $exception, + "Moose::Exception::MethodModifierNeedsMethodName", + "no method name passed to method modifier"); + + is( + $exception->class_name, + "Foo", + "no method name passed to method modifier"); +} + +{ + { + package Foo; + use Moose; + } + my $exception = exception { + Foo->meta->add_after_method_modifier; + }; + + like( + $exception, + qr/You must pass in a method name/, + "no method name passed to method modifier"); + + isa_ok( + $exception, + "Moose::Exception::MethodModifierNeedsMethodName", + "no method name passed to method modifier"); + + is( + $exception->class_name, + "Foo", + "no method name passed to method modifier"); +} + +{ + { + package Foo; + use Moose; + } + my $exception = exception { + Foo->meta->add_around_method_modifier; + }; + + like( + $exception, + qr/You must pass in a method name/, + "no method name passed to method modifier"); + + isa_ok( + $exception, + "Moose::Exception::MethodModifierNeedsMethodName", + "no method name passed to method modifier"); + + is( + $exception->class_name, + "Foo", + "no method name passed to method modifier"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->_construct_class_instance; + }; + + like( + $exception, + qr/You must pass a package name/, + "no package name given to _construct_class_instance"); + + isa_ok( + $exception, + "Moose::Exception::ConstructClassInstanceTakesPackageName", + "no package name given to _construct_class_instance"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->add_before_method_modifier("foo"); + }; + + like( + $exception, + qr/The method 'foo' was not found in the inheritance hierarchy for Foo/, + 'method "foo" is not defined in class "Foo"'); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotFoundInInheritanceHierarchy", + 'method "foo" is not defined in class "Foo"'); + + is( + $exception->class_name, + 'Foo', + 'method "foo" is not defined in class "Foo"'); + + is( + $exception->method_name, + 'foo', + 'method "foo" is not defined in class "Foo"'); +} + +{ + { + package Bar; + use Moose; + } + my $bar = Bar->new; + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->new_object( ( __INSTANCE__ => $bar ) ); + }; + + like( + $exception, + qr/\QObjects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but $bar is not a Foo/, + "__INSTANCE__ is not blessed correctly"); + #Objects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but Bar=HASH(0x2d77528) is not a Foo + + isa_ok( + $exception, + "Moose::Exception::InstanceBlessedIntoWrongClass", + "__INSTANCE__ is not blessed correctly"); + + is( + $exception->class_name, + 'Foo', + "__INSTANCE__ is not blessed correctly"); + + is( + $exception->instance, + $bar, + "__INSTANCE__ is not blessed correctly"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $array = [1,2,3]; + my $exception = exception { + $class->new_object( ( __INSTANCE__ => $array ) ); + }; + + like( + $exception, + qr/\QThe __INSTANCE__ parameter must be a blessed reference, not $array/, + "__INSTANCE__ is not a blessed reference"); + #The __INSTANCE__ parameter must be a blessed reference, not ARRAY(0x1d75d40) + + isa_ok( + $exception, + "Moose::Exception::InstanceMustBeABlessedReference", + "__INSTANCE__ is not a blessed reference"); + + is( + $exception->class_name, + 'Foo', + "__INSTANCE__ is not a blessed reference"); + + is( + $exception->instance, + $array, + "__INSTANCE__ is not a blessed reference"); +} + +{ + my $array = [1, 2, 3]; + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->_clone_instance($array); + }; + + like( + $exception, + qr/\QYou can only clone instances, ($array) is not a blessed instance/, + "array reference was passed to _clone_instance instead of a blessed instance"); + #You can only clone instances, (ARRAY(0x2162350)) is not a blessed instance + + isa_ok( + $exception, + "Moose::Exception::OnlyInstancesCanBeCloned", + "array reference was passed to _clone_instance instead of a blessed instance"); + + is( + $exception->class_name, + "Foo", + "array reference was passed to _clone_instance instead of a blessed instance"); + + is( + $exception->instance, + $array, + "array reference was passed to _clone_instance instead of a blessed instance"); +} + +{ + { + package My::Role; + use Moose::Role; + } + + my $exception = exception { + Class::MOP::Class->create("My::Class", superclasses => ["My::Role"]); + }; + + like( + $exception, + qr/\QThe metaclass of My::Class (Class::MOP::Class) is not compatible with the metaclass of its superclass, My::Role (Moose::Meta::Role) /, + "Trying to inherit a Role"); + + isa_ok( + $exception, + "Moose::Exception::IncompatibleMetaclassOfSuperclass", + "Trying to inherit a Role"); + + is( + $exception->class_name, + "My::Class", + "Trying to inherit a Role"); + + is( + $exception->superclass_name, + "My::Role", + "Trying to inherit a Role"); +} + +{ + { + package Super::Class; + use Moose; + } + + my $class = Class::MOP::Class->create("TestClass", superclasses => ["Super::Class"]); + $class->immutable_trait(undef); + my $exception = exception { + $class->make_immutable( immutable_trait => ''); + }; + + like( + $exception, + qr/\Qno immutable trait specified for $class/, + "immutable_trait set to undef"); + #no immutable trait specified for Moose::Meta::Class=HASH(0x19a2280) + + isa_ok( + $exception, + "Moose::Exception::NoImmutableTraitSpecifiedForClass", + "immutable_trait set to undef"); + + is( + $exception->class_name, + "TestClass", + "immutable_trait set to undef"); +} + +{ + my $exception = exception { + package NoDestructorClass; + use Moose; + + __PACKAGE__->meta->make_immutable( destructor_class => undef, inline_destructor => 1 ); + }; + + like( + $exception, + qr/The 'inline_destructor' option is present, but no destructor class was specified/, + "destructor_class is set to undef"); + + isa_ok( + $exception, + "Moose::Exception::NoDestructorClassSpecified", + "destructor_class is set to undef"); + + is( + $exception->class_name, + "NoDestructorClass", + "destructor_class is set to undef"); +} + +{ + { + package Foo9::Meta::Role; + use Moose::Role; + } + + { + package Foo9::SuperClass::WithMetaRole; + use Moose -traits =>'Foo9::Meta::Role'; + } + + { + package Foo9::Meta::OtherRole; + use Moose::Role; + } + + { + package Foo9::SuperClass::After::Attribute; + use Moose -traits =>'Foo9::Meta::OtherRole'; + } + + my $exception = exception { + { + package Foo9; + use Moose; + my @superclasses = ('Foo9::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo9::SuperClass::After::Attribute'); + + extends @superclasses; + } + }; + + like( + $exception, + qr/\QCan't fix metaclass incompatibility for Foo9 because it is not pristine./, + "cannot make metaclass compatible"); + + isa_ok( + $exception, + "Moose::Exception::CannotFixMetaclassCompatibility", + "cannot make metaclass compatible"); + + is( + $exception->class_name, + "Foo9", + "cannot make metaclass compatible"); +} + +{ + Class::MOP::Class->create( "Foo::Meta::Attribute", + superclasses => ["Class::MOP::Attribute"] + ); + + Class::MOP::Class->create( "Bar::Meta::Attribute", + superclasses => ["Class::MOP::Attribute"] + ); + + Class::MOP::Class->create( "Foo::Meta::Class", + superclasses => ["Class::MOP::Class"] + ); + + Foo::Meta::Class->create( + 'Foo::All', + attribute_metaclass => "Foo::Meta::Attribute", + ); + + { + Class::MOP::Class->create( + 'Foo::Unsafe', + attribute_metaclass => 'Foo::Meta::Attribute', + ); + + my $meta = Class::MOP::Class->create( + 'Foo::Unsafe::Sub', + ); + + $meta->add_attribute(foo => reader => 'foo'); + + my $exception = exception { + $meta->superclasses('Foo::Unsafe'); + }; + + like( + $exception, + qr/\QCan't fix metaclass incompatibility for Foo::Unsafe::Sub because it is not pristine./, + "cannot make metaclass compatible"); + + isa_ok( + $exception, + "Moose::Exception::CannotFixMetaclassCompatibility", + "cannot make metaclass compatible"); + + is( + $exception->class_name, + "Foo::Unsafe::Sub", + "cannot make metaclass compatible"); + } + + { + my $exception = exception { + Foo::Meta::Class->create( + "Foo::All::Sub::Attribute", + superclasses => ['Foo::All'], + attribute_metaclass => "Foo::Meta::Attribute", + attribute_metaclass => "Bar::Meta::Attribute", + ) + }; + + like( + $exception, + qr/\QThe attribute_metaclass metaclass for Foo::All::Sub::Attribute (Bar::Meta::Attribute) is not compatible with the attribute metaclass of its superclass, Foo::All (Foo::Meta::Attribute)/, + "incompatible attribute_metaclass"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassTypeIncompatible", + "incompatible attribute_metaclass"); + + is( + $exception->class_name, + "Foo::All::Sub::Attribute", + "incompatible attribute_metaclass"); + + is( + $exception->superclass_name, + "Foo::All", + "incompatible attribute_metaclass"); + + is( + $exception->metaclass_type, + "attribute_metaclass", + "incompatible attribute_metaclass"); + } +} + +done_testing; diff --git a/t/exceptions/class-mop-method-accessor.t b/t/exceptions/class-mop-method-accessor.t new file mode 100644 index 0000000..b83a2df --- /dev/null +++ b/t/exceptions/class-mop-method-accessor.t @@ -0,0 +1,279 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Accessor->new; + }; + + like( + $exception, + qr/\QYou must supply an attribute to construct with/, + "no attribute is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAnAttributeToConstructWith", + "no attribute is given"); +} + +{ + my $exception = exception { + Class::MOP::Method::Accessor->new( attribute => "foo" ); + }; + + like( + $exception, + qr/\QYou must supply an accessor_type to construct with/, + "no accessor_type is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAnAccessorTypeToConstructWith", + "no accessor_type is given"); +} + +{ + my $exception = exception { + Class::MOP::Method::Accessor->new( accessor_type => 'reader', attribute => "foo" ); + }; + + like( + $exception, + qr/\QYou must supply an attribute which is a 'Class::MOP::Attribute' instance/, + "attribute isn't an instance of Class::MOP::Attribute"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAClassMOPAttributeInstance", + "attribute isn't an instance of Class::MOP::Attribute"); +} + +{ + my $attr = Class::MOP::Attribute->new("Foo", ( is => 'ro')); + my $exception = exception { + Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr); + }; + + like( + $exception, + qr/\QYou must supply the package_name and name parameters/, + "no package_name and name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "no package_name and name is given"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_accessor_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline accessor because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "accessor", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_reader_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline reader because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "reader", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_writer_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline writer because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "writer", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_predicate_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline predicate because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "predicate", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_clearer_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline clearer because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "clearer", + "can't call get_meta_instance on an undefined value"); +} + +{ + { + package Foo::ReadOnlyAccessor; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Int', + ); + } + + my $foo = Foo::ReadOnlyAccessor->new; + + my $exception = exception { + $foo->foo(120); + }; + + like( + $exception, + qr/Cannot assign a value to a read-only accessor/, + "foo is read only"); + + isa_ok( + $exception, + "Moose::Exception::CannotAssignValueToReadOnlyAccessor", + "foo is read only"); + + is( + $exception->class_name, + "Foo::ReadOnlyAccessor", + "foo is read only"); + + is( + $exception->attribute_name, + "foo", + "foo is read only"); + + is( + $exception->value, + 120, + "foo is read only"); +} + +{ + { + package Point; + use metaclass; + + Point->meta->add_attribute('x' => ( + reader => 'x', + init_arg => 'x' + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } + } + + my $point = Point->new(); + + my $exception = exception { + $point->x(120); + }; + + like( + $exception, + qr/Cannot assign a value to a read-only accessor/, + "x is read only"); + + isa_ok( + $exception, + "Moose::Exception::CannotAssignValueToReadOnlyAccessor", + "x is read only"); + + is( + $exception->class_name, + "Point", + "x is read only"); + + is( + $exception->attribute_name, + "x", + "x is read only"); + + is( + $exception->value, + 120, + "x is read only"); +} +done_testing; diff --git a/t/exceptions/class-mop-method-constructor.t b/t/exceptions/class-mop-method-constructor.t new file mode 100644 index 0000000..dd87f4a --- /dev/null +++ b/t/exceptions/class-mop-method-constructor.t @@ -0,0 +1,75 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Constructor->new( is_inline => 1); + }; + + like( + $exception, + qr/\QYou must pass a metaclass instance if you want to inline/, + "no metaclass is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAMetaclass", + "no metaclass is given"); +} + +{ + my $exception = exception { + Class::MOP::Method::Constructor->new; + }; + + like( + $exception, + qr/\QYou must supply the package_name and name parameters/, + "no package_name and name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "no package_name and name is given"); +} + +{ + BEGIN + { + { + package NewMetaClass; + use Moose; + extends 'Moose::Meta::Class'; + + sub _inline_new_object { + return 'print "xyz'; # this is a intentional syntax error, + } + } + }; + + { + package BadConstructorClass; + use Moose -metaclass => 'NewMetaClass'; + } + + my $exception = exception { + BadConstructorClass->meta->make_immutable(); + }; + + like( + $exception, + qr/Could not eval the constructor :/, + "syntax error in _inline_new_object"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotEvalConstructor", + "syntax error in _inline_new_object"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method-generated.t b/t/exceptions/class-mop-method-generated.t new file mode 100644 index 0000000..59a91b6 --- /dev/null +++ b/t/exceptions/class-mop-method-generated.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Generated->new; + }; + + like( + $exception, + qr/\QClass::MOP::Method::Generated is an abstract base class, you must provide a constructor./, + "trying to call an abstract base class constructor"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractBaseMethod", + "trying to call an abstract base class constructor"); +} + +{ + my $exception = exception { + Class::MOP::Method::Generated->_initialize_body; + }; + + like( + $exception, + qr/\QNo body to initialize, Class::MOP::Method::Generated is an abstract base class/, + "trying to call a method of an abstract class"); + + isa_ok( + $exception, + "Moose::Exception::NoBodyToInitializeInAnAbstractBaseClass", + "trying to call a method of an abstract class"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method-meta.t b/t/exceptions/class-mop-method-meta.t new file mode 100644 index 0000000..ddd51aa --- /dev/null +++ b/t/exceptions/class-mop-method-meta.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Meta->wrap("Foo", ( body => 'foo' )); + }; + + like( + $exception, + qr/\QOverriding the body of meta methods is not allowed/, + "body is given to Class::MOP::Method::Meta->wrap"); + + isa_ok( + $exception, + "Moose::Exception::CannotOverrideBodyOfMetaMethods", + "body is given to Class::MOP::Method::Meta->wrap"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method-wrapped.t b/t/exceptions/class-mop-method-wrapped.t new file mode 100644 index 0000000..bf96dd8 --- /dev/null +++ b/t/exceptions/class-mop-method-wrapped.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Wrapped->wrap("Foo"); + }; + + like( + $exception, + qr/\QCan only wrap blessed CODE/, + "no CODE is given to wrap"); + + isa_ok( + $exception, + "Moose::Exception::CanOnlyWrapBlessedCode", + "no CODE is given to wrap"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method.t b/t/exceptions/class-mop-method.t new file mode 100644 index 0000000..c85cc7b --- /dev/null +++ b/t/exceptions/class-mop-method.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method->wrap( "foo", ( name => "Bar")); + }; + + like( + $exception, + qr/\QYou must supply a CODE reference to bless, not (foo)/, + "first argument to wrap should be a CODE ref"); + + isa_ok( + $exception, + "Moose::Exception::WrapTakesACodeRefToBless", + "first argument to wrap should be a CODE ref"); +} + +{ + my $exception = exception { + Class::MOP::Method->wrap( sub { "foo" }, ()); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "no package name is given to wrap"); + + isa_ok( + $exception, + "Moose::Exception::PackageNameAndNameParamsNotGivenToWrap", + "no package name is given to wrap"); +} + +done_testing; diff --git a/t/exceptions/class-mop-mixin-hasattributes.t b/t/exceptions/class-mop-mixin-hasattributes.t new file mode 100644 index 0000000..c498c4c --- /dev/null +++ b/t/exceptions/class-mop-mixin-hasattributes.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $xyz = bless [], "Bar"; + my $class; + my $exception = exception { + $class = Class::MOP::Class->create("Foo", (attributes => [$xyz])); + }; + + like( + $exception, + qr/\QYour attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)/, + "an Array ref blessed into Bar is given to create"); + + isa_ok( + $exception, + "Moose::Exception::AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass", + "an Array ref blessed into Bar is given to create"); + + is( + $exception->attribute, + $xyz, + "an Array ref blessed into Bar is given to create"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->has_attribute; + }; + + like( + $exception, + qr/You must define an attribute name/, + "attribute name is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAnAttributeName", + "attribute name is not given"); + + is( + $exception->class_name, + 'Foo', + "attribute name is not given"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->get_attribute; + }; + + like( + $exception, + qr/You must define an attribute name/, + "attribute name is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAnAttributeName", + "attribute name is not given"); + + is( + $exception->class_name, + "Foo", + "attribute name is not given"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->remove_attribute; + }; + + like( + $exception, + qr/You must define an attribute name/, + "attribute name is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAnAttributeName", + "attribute name is not given"); + + is( + $exception->class_name, + "Foo", + "attribute name is not given"); +} + +done_testing; diff --git a/t/exceptions/class-mop-mixin-hasmethods.t b/t/exceptions/class-mop-mixin-hasmethods.t new file mode 100644 index 0000000..d0d39dd --- /dev/null +++ b/t/exceptions/class-mop-mixin-hasmethods.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->has_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->add_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->get_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->remove_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Bar::Role; + use Moose::Role; + } + + my $meta = Bar::Role->meta; + + my $exception = exception { + $meta->wrap_method_body; + }; + + like( + $exception, + qr/Your code block must be a CODE reference/, + "no arguments passed to wrap_method_body"); + + isa_ok( + $exception, + "Moose::Exception::CodeBlockMustBeACodeRef", + "no arguments passed to wrap_method_body"); + + is( + $exception->instance, + $meta, + "no arguments passed to wrap_method_body"); +} + +done_testing; diff --git a/t/exceptions/class-mop-module.t b/t/exceptions/class-mop-module.t new file mode 100644 index 0000000..604fa88 --- /dev/null +++ b/t/exceptions/class-mop-module.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Module->create_anon(cache => 1); + }; + + like( + $exception, + qr/Modules are not cacheable/, + "can't cache anon packages"); + + isa_ok( + $exception, + "Moose::Exception::PackagesAndModulesAreNotCachable", + "can't cache anon packages"); +} + +done_testing; diff --git a/t/exceptions/class-mop-object.t b/t/exceptions/class-mop-object.t new file mode 100644 index 0000000..b41f93a --- /dev/null +++ b/t/exceptions/class-mop-object.t @@ -0,0 +1,109 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + use Moose (); + # XXX call cmop version of throw_error here instead! + Moose->throw_error("Hello, I am an exception object"); + }; + + like( + $exception, + qr/Hello, I am an exception object/, + "throw_error stringifies to the message"); + + isa_ok( + $exception, + 'Moose::Exception::Legacy', + "exception"); +} + +{ + my $exception = exception { + use Moose (); + Moose->throw_error("Hello, ", "I am an ", "exception object"); + }; + + like( + $exception, + qr/Hello, I am an exception object/, + "throw_error stringifies to the full message"); + + isa_ok( + $exception, + 'Moose::Exception::Legacy', + "exception"); +} + +{ + BEGIN + { + { + package FooRole; + use Moose::Role; + + sub xyz { + print "In xyz method"; + } + } + + { + package FooMetaclass; + use Moose; + with 'FooRole'; + extends 'Moose::Meta::Class'; + + sub _inline_check_required_attr { + my $self = shift; + my ($attr) = @_; + + return unless defined $attr->init_arg; + return unless $attr->can('is_required') && $attr->is_required; + return if $attr->has_default || $attr->has_builder; + + return ( + 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_throw_error( + 'Legacy => '. + 'message => "An inline error" ' + ).';', + '}', + ); + } + } + } +}; + +{ + { + package Foo2; + use Moose -metaclass => 'FooMetaclass'; + + has 'baz' => ( + is => 'ro', + isa => 'Int', + required => 1, + ); + __PACKAGE__->meta->make_immutable; + } + + my $exception = exception { + my $test1 = Foo2->new; + }; + + like( + $exception, + qr/An inline error/, + "_inline_throw_error stringifies to the message"); + + isa_ok( + $exception, + 'Moose::Exception::Legacy', + "_inline_throw_error stringifies to the message"); +} + +done_testing(); diff --git a/t/exceptions/class-mop-package.t b/t/exceptions/class-mop-package.t new file mode 100644 index 0000000..4cf78e7 --- /dev/null +++ b/t/exceptions/class-mop-package.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Package->reinitialize; + }; + + like( + $exception, + qr/\QYou must pass a package name or an existing Class::MOP::Package instance/, + "no package name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAPackageNameOrAnExistingClassMOPPackageInstance", + "no package name is given"); +} + +{ + my $exception = exception { + Class::MOP::Package->create_anon(cache => 1); + }; + + like( + $exception, + qr/Packages are not cacheable/, + "can't cache anon packages"); + + isa_ok( + $exception, + "Moose::Exception::PackagesAndModulesAreNotCachable", + "can't cache anon packages"); +} + +done_testing; diff --git a/t/exceptions/class.t b/t/exceptions/class.t new file mode 100644 index 0000000..6adddc9 --- /dev/null +++ b/t/exceptions/class.t @@ -0,0 +1,304 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + Moose::Meta::Class->create( + 'Made::Of::Fail', + superclasses => ['Class'], + roles => 'Foo', + ); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of roles/, + "create takes an Array of roles"); + + isa_ok( + $exception, + "Moose::Exception::RolesInCreateTakesAnArrayRef", + "create takes an Array of roles"); +} + +{ + use Moose::Meta::Class; + + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->meta->add_role('Bar'); + }; + + like( + $exception, + qr/Roles must be instances of Moose::Meta::Role/, + "add_role takes an instance of Moose::Meta::Role"); + + isa_ok( + $exception, + 'Moose::Exception::AddRoleTakesAMooseMetaRoleInstance', + "add_role takes an instance of Moose::Meta::Role"); + + is( + $exception->class_name, + 'Foo', + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + is( + $exception->role_to_be_added, + "Bar", + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + Foo->meta->add_role_application(); + }; + + like( + $exception, + qr/Role applications must be instances of Moose::Meta::Role::Application::ToClass/, + "bar is not an instance of Moose::Meta::Role::Application::ToClass"); + + isa_ok( + $exception, + "Moose::Exception::InvalidRoleApplication", + "bar is not an instance of Moose::Meta::Role::Application::ToClass"); +} + +# tests for Moose::Meta::Class::does_role +{ + use Moose::Meta::Class; + + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->meta->does_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "Cannot call does_role without a role name"); + + isa_ok( + $exception, + 'Moose::Exception::RoleNameRequired', + "Cannot call does_role without a role name"); + + is( + $exception->class_name, + 'Foo', + "Cannot call does_role without a role name"); +} + +# tests for Moose::Meta::Class::excludes_role +{ + use Moose::Meta::Class; + + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->meta->excludes_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "Cannot call excludes_role without a role name"); + + isa_ok( + $exception, + 'Moose::Exception::RoleNameRequired', + "Cannot call excludes_role without a role name"); + + is( + $exception->class_name, + 'Foo', + "Cannot call excludes_role without a role name"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; + Foo->new([]) + }; + + like( + $exception, + qr/^\QSingle parameters to new() must be a HASH ref/, + "A single non-hashref arg to a constructor throws an error"); + + isa_ok( + $exception, + "Moose::Exception::SingleParamsToNewMustBeHashRef", + "A single non-hashref arg to a constructor throws an error"); +} + +# tests for AttributeIsRequired for inline excpetions +{ + { + package Foo2; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Int', + required => 1, + ); + __PACKAGE__->meta->make_immutable; + } + + my $exception = exception { + my $test1 = Foo2->new; + }; + + like( + $exception, + qr/\QAttribute (baz) is required/, + "... must supply all the required attribute"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "... must supply all the required attribute"); + + is( + $exception->attribute_name, + 'baz', + "... must supply all the required attribute"); + + isa_ok( + $exception->class_name, + 'Foo2', + "... must supply all the required attribute"); +} + +{ + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + package Foo3; + use Moose; + extends 'Bar'; + }; + + like( + $exception, + qr/^\QYou cannot inherit from a Moose Role (Bar)/, + "Class cannot extend a role"); + + isa_ok( + $exception, + 'Moose::Exception::CanExtendOnlyClasses', + "Class cannot extend a role"); + + is( + $exception->role_name, + 'Bar', + "Class cannot extend a role"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + sub foo2 {} + override foo2 => sub {}; + }; + + like( + $exception, + qr/Cannot add an override method if a local method is already present/, + "there is already a method named foo2 defined in the class, so you can't override it"); + + isa_ok( + $exception, + 'Moose::Exception::CannotOverrideLocalMethodIsPresent', + "there is already a method named foo2 defined in the class, so you can't override it"); + + is( + $exception->class_name, + 'Foo', + "there is already a method named foo2 defined in the class, so you can't override it"); + + is( + $exception->method->name, + 'foo2', + "there is already a method named foo2 defined in the class, so you can't override it"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + sub foo {} + augment foo => sub {}; + }; + + like( + $exception, + qr/Cannot add an augment method if a local method is already present/, + "there is already a method named foo defined in the class"); + + isa_ok( + $exception, + 'Moose::Exception::CannotAugmentIfLocalMethodPresent', + "there is already a method named foo defined in the class"); + + is( + $exception->class_name, + 'Foo', + "there is already a method named foo defined in the class"); + + is( + $exception->method->name, + 'foo', + "there is already a method named foo defined in the class"); +} + +{ + { + package Test; + use Moose; + } + + my $exception = exception { + package Test2; + use Moose; + extends 'Test'; + has '+bar' => ( default => 100 ); + }; + + like( + $exception, + qr/Could not find an attribute by the name of 'bar' to inherit from in Test2/, + "attribute 'bar' is not defined in the super class"); + + isa_ok( + $exception, + "Moose::Exception::NoAttributeFoundInSuperClass", + "attribute 'bar' is not defined in the super class"); +} + +done_testing; diff --git a/t/exceptions/cmop.t b/t/exceptions/cmop.t new file mode 100644 index 0000000..9021591 --- /dev/null +++ b/t/exceptions/cmop.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + my $exception = exception { + Class::MOP::Mixin->_throw_exception(Legacy => message => 'oh hai'); + }; + ok( + $exception->isa('Moose::Exception::Legacy'), + 'threw the right type', + ); + is($exception->message, 'oh hai', 'got the message attribute'); +} + +done_testing; diff --git a/t/exceptions/exception-lazyattributeneedsadefault.t b/t/exceptions/exception-lazyattributeneedsadefault.t new file mode 100644 index 0000000..c0eb4a2 --- /dev/null +++ b/t/exceptions/exception-lazyattributeneedsadefault.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util 'throw_exception'; + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro' + ); + + has 'bar' => ( + is => 'ro' + ); +} + +{ + my $exception = exception { + throw_exception( LazyAttributeNeedsADefault => attribute_name => "foo", + attribute => Foo->meta->get_attribute("bar") + ); + }; + + like( + $exception, + qr/\Qattribute_name (foo) does not match attribute->name (bar)/, + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); + + isa_ok( + $exception, + "Moose::Exception::AttributeNamesDoNotMatch", + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); + + is( + $exception->attribute_name, + "foo", + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); + + is( + $exception->attribute->name, + "bar", + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); +} + +{ + my $exception = exception { + throw_exception("LazyAttributeNeedsADefault"); + }; + + like( + $exception, + qr/\QYou need to give attribute or attribute_name or both/, + "please give either attribute or attribute_name"); + + isa_ok( + $exception, + "Moose::Exception::NeitherAttributeNorAttributeNameIsGiven", + "please give either attribute or attribute_name"); +} + +done_testing; diff --git a/t/exceptions/frame-leak.t b/t/exceptions/frame-leak.t new file mode 100644 index 0000000..e11bd63 --- /dev/null +++ b/t/exceptions/frame-leak.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Requires 'Test::Memory::Cycle'; + +BEGIN { + plan skip_all => 'Leak tests fail under Devel::Cover' if $INC{'Devel/Cover.pm'}; +} + +{ + package Foo; + use Moose; + has myattr => ( is => 'ro', required => 1 ); +} + +memory_cycle_ok( + exception { Foo->new() }, + 'exception objects do not leak arguments into Devel::StackTrace objects', +); + +done_testing; diff --git a/t/exceptions/meta-role.t b/t/exceptions/meta-role.t new file mode 100644 index 0000000..2fb1013 --- /dev/null +++ b/t/exceptions/meta-role.t @@ -0,0 +1,242 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + { + package JustATestRole; + use Moose::Role; + } + + { + package JustATestClass; + use Moose; + } + + my $class = JustATestClass->meta; + my $exception = exception { + JustATestRole->meta->add_attribute( $class ); + }; + + like( + $exception, + qr/\QCannot add a Moose::Meta::Class as an attribute to a role/, + "Roles cannot have a class as an attribute"); + + isa_ok( + $exception, + "Moose::Exception::CannotAddAsAnAttributeToARole", + "Roles cannot have a class as an attribute"); + + is( + $exception->role_name, + 'JustATestRole', + "Roles cannot have a class as an attribute"); + + is( + $exception->attribute_class, + "Moose::Meta::Class", + "Roles cannot have a class as an attribute"); +} + +{ + my $exception = exception { + package JustATestRole; + use Moose::Role; + + has '+attr' => ( + is => 'ro', + ); + }; + + like( + $exception, + qr/\Qhas '+attr' is not supported in roles/, + "Attribute Extension is not supported in roles"); + + isa_ok( + $exception, + "Moose::Exception::AttributeExtensionIsNotSupportedInRoles", + "Attribute Extension is not supported in roles"); + + is( + $exception->role_name, + 'JustATestRole', + "Attribute Extension is not supported in roles"); + + is( + $exception->attribute_name, + "+attr", + "Attribute Extension is not supported in roles"); +} + +{ + my $exception = exception { + package JustATestRole; + use Moose::Role; + + sub bar {} + + override bar => sub {}; + }; + + like( + $exception, + qr/\QCannot add an override of method 'bar' because there is a local version of 'bar'/, + "Cannot override bar, because it's a local method"); + + isa_ok( + $exception, + "Moose::Exception::CannotOverrideALocalMethod", + "Cannot override bar, because it's a local method"); + + is( + $exception->role_name, + 'JustATestRole', + "Cannot override bar, because it's a local method"); + + is( + $exception->method_name, + "bar", + "Cannot override bar, because it's a local method"); +} + +{ + { + package JustATestRole; + use Moose::Role; + } + + my $exception = exception { + JustATestRole->meta->add_role("xyz"); + }; + + like( + $exception, + qr/\QRoles must be instances of Moose::Meta::Role/, + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + isa_ok( + $exception, + "Moose::Exception::AddRoleToARoleTakesAMooseMetaRole", + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + is( + $exception->role_name, + 'JustATestRole', + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + is( + $exception->role_to_be_added, + "xyz", + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); +} + +{ + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + Bar->meta->does_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "Cannot call does_role without a role name"); + + isa_ok( + $exception, + 'Moose::Exception::RoleNameRequiredForMooseMetaRole', + "Cannot call does_role without a role name"); + + is( + $exception->role_name, + 'Bar', + "Cannot call does_role without a role name"); +} + +{ + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + Bar->meta->apply("xyz"); + }; + + like( + $exception, + qr/You must pass in an blessed instance/, + "apply takes a blessed instance"); + + isa_ok( + $exception, + 'Moose::Exception::ApplyTakesABlessedInstance', + "apply takes a blessed instance"); + + is( + $exception->role_name, + 'Bar', + "apply takes a blessed instance"); + + is( + $exception->param, + 'xyz', + "apply takes a blessed instance"); +} + +{ + my $exception = exception { + Moose::Meta::Role->create("TestRole", ( 'attributes' => 'bar')); + }; + + like( + $exception, + qr/You must pass a HASH ref of attributes/, + "create takes a HashRef of attributes"); + + isa_ok( + $exception, + "Moose::Exception::CreateTakesHashRefOfAttributes", + "create takes a HashRef of attributes"); +} + +{ + my $exception = exception { + Moose::Meta::Role->create("TestRole", ( 'methods' => 'bar')); + }; + + like( + $exception, + qr/You must pass a HASH ref of methods/, + "create takes a HashRef of methods"); + + isa_ok( + $exception, + "Moose::Exception::CreateTakesHashRefOfMethods", + "create takes a HashRef of methods"); +} + +{ + my $exception = exception { + Moose::Meta::Role->create("TestRole", ('roles', 'bar')); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of roles/, + "create takes an ArrayRef of roles"); + + isa_ok( + $exception, + "Moose::Exception::CreateTakesArrayRefOfRoles", + "create takes an ArrayRef of roles"); +} + +done_testing; diff --git a/t/exceptions/metaclass.t b/t/exceptions/metaclass.t new file mode 100644 index 0000000..5492df1 --- /dev/null +++ b/t/exceptions/metaclass.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + require metaclass; + metaclass->import( ("Foo") ); + }; + + like( + $exception, + qr/\QThe metaclass (Foo) must be derived from Class::MOP::Class/, + "Foo is not derived from Class::MOP::Class"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass", + "Foo is not derived from Class::MOP::Class"); + + is( + $exception->class_name, + 'Foo', + "Foo is not derived from Class::MOP::Class"); +} + +done_testing; diff --git a/t/exceptions/moose-exporter.t b/t/exceptions/moose-exporter.t new file mode 100644 index 0000000..7852176 --- /dev/null +++ b/t/exceptions/moose-exporter.t @@ -0,0 +1,119 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + package MooseX::NoAlso; + use Moose (); + + Moose::Exporter->setup_import_methods( + also => ['NoSuchThing'] + ); + }; + + like( + $exception, + qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?)/, + 'a package which does not use Moose::Exporter in also dies with an error'); + + isa_ok( + $exception, + 'Moose::Exception::PackageDoesNotUseMooseExporter', + 'a package which does not use Moose::Exporter in also dies with an error'); + + is( + $exception->package, + "NoSuchThing", + 'a package which does not use Moose::Exporter in also dies with an error'); +} + +{ + my $exception = exception { + { + package MooseX::CircularAlso; + use Moose; + + Moose::Exporter->setup_import_methods( + also => [ 'Moose', 'MooseX::CircularAlso' ], + ); + } + }; + + like( + $exception, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, + 'a circular reference in also dies with an error'); + + isa_ok( + $exception, + 'Moose::Exception::CircularReferenceInAlso', + 'a circular reference in also dies with an error'); + + is( + $exception->also_parameter, + "MooseX::CircularAlso", + 'a circular reference in also dies with an error'); +} + +{ + { + package My::SimpleTrait; + use Moose::Role; + + sub simple { return 5 } + } + + use Moose::Util::TypeConstraints; + my $exception = exception { + Moose::Util::TypeConstraints->import( + -traits => 'My::SimpleTrait' ); + }; + + like( + $exception, + qr/\QCannot provide traits when Moose::Util::TypeConstraints does not have an init_meta() method/, + 'cannot provide -traits to an exporting module that does not init_meta'); + + isa_ok( + $exception, + "Moose::Exception::ClassDoesNotHaveInitMeta", + 'cannot provide -traits to an exporting module that does not init_meta'); + + is( + $exception->class_name, + "Moose::Util::TypeConstraints", + 'cannot provide -traits to an exporting module that does not init_meta'); +} + +{ + my $exception = exception { + { + package MooseX::BadTraits; + use Moose (); + + Moose::Exporter->setup_import_methods( + trait_aliases => [{hello => 1}] + ); + } + }; + + like( + $exception, + qr/HASH references are not valid arguments to the 'trait_aliases' option/, + "a HASH ref is given to trait_aliases"); + + isa_ok( + $exception, + "Moose::Exception::InvalidArgumentsToTraitAliases", + "a HASH ref is given to trait_aliases"); + + is( + $exception->package_name, + "MooseX::BadTraits", + "a HASH ref is given to trait_aliases"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-attribute-native-traits.t b/t/exceptions/moose-meta-attribute-native-traits.t new file mode 100644 index 0000000..64ba085 --- /dev/null +++ b/t/exceptions/moose-meta-attribute-native-traits.t @@ -0,0 +1,147 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose; + +{ + my $exception = exception { + { + package TestClass; + use Moose; + + has 'foo' => ( + traits => ['Array'], + is => 'ro', + isa => 'Int' + ); + } + }; + + like( + $exception, + qr/The type constraint for foo must be a subtype of ArrayRef but it's a Int/, + "isa is given as Int, but it should be ArrayRef"); + + isa_ok( + $exception, + 'Moose::Exception::WrongTypeConstraintGiven', + "isa is given as Int, but it should be ArrayRef"); + + is( + $exception->required_type, + "ArrayRef", + "isa is given as Int, but it should be ArrayRef"); + + is( + $exception->given_type, + "Int", + "isa is given as Int, but it should be ArrayRef"); + + is( + $exception->attribute_name, + "foo", + "isa is given as Int, but it should be ArrayRef"); +} + +{ + my $exception = exception { + { + package TestClass2; + use Moose; + + has 'foo' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef', + handles => 'bar' + ); + } + }; + + like( + $exception, + qr/The 'handles' option must be a HASH reference, not bar/, + "'bar' is given as handles"); + + isa_ok( + $exception, + 'Moose::Exception::HandlesMustBeAHashRef', + "'bar' is given as handles"); + + is( + $exception->given_handles, + "bar", + "'bar' is given as handles"); +} + +{ + my $exception = exception { + { + package TraitTest; + use Moose::Role; + with 'Moose::Meta::Attribute::Native::Trait'; + + sub _helper_type { "ArrayRef" } + } + + { + package TestClass3; + use Moose; + + has 'foo' => ( + traits => ['TraitTest'], + is => 'ro', + isa => 'ArrayRef', + handles => { get_count => 'count' } + ); + } + }; + + like( + $exception, + qr/\QCannot calculate native type for Moose::Meta::Class::__ANON__::SERIAL::/, + "cannot calculate native type for the given trait"); + + isa_ok( + $exception, + 'Moose::Exception::CannotCalculateNativeType', + "cannot calculate native type for the given trait"); +} + +{ + my $regex = qr/bar/; + my $exception = exception { + { + package TestClass4; + use Moose; + + has 'foo' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef', + handles => { get_count => $regex } + ); + } + }; + + like( + $exception, + qr/\QAll values passed to handles must be strings or ARRAY references, not $regex/, + "a Regexp is given to handles"); + #All values passed to handles must be strings or ARRAY references, not (?^:bar) + + isa_ok( + $exception, + 'Moose::Exception::InvalidHandleValue', + "a Regexp is given to handles"); + + is( + $exception->handle_value, + $regex, + "a Regexp is given to handles"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-class-immutable-trait.t b/t/exceptions/moose-meta-class-immutable-trait.t new file mode 100644 index 0000000..c355240 --- /dev/null +++ b/t/exceptions/moose-meta-class-immutable-trait.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + package Foo; + use Moose; + + __PACKAGE__->meta->make_immutable; + Foo->meta->does_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "no role_name supplied to does_role"); + + isa_ok( + $exception, + "Moose::Exception::RoleNameRequired", + "no role_name supplied to does_role"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-array.t b/t/exceptions/moose-meta-method-accessor-native-array.t new file mode 100644 index 0000000..d923935 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-array.t @@ -0,0 +1,488 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'ArrayRef', + traits => ['Array'], + handles => { + get => 'get', + first => 'first', + first_index => 'first_index', + grep => 'grep', + join => 'join', + map => 'map', + natatime => 'natatime', + reduce => 'reduce', + sort => 'sort', + sort_in_place => 'sort_in_place', + splice => 'splice' + }, + required => 1 + ); +} + +my $foo_obj; + +{ + + my $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $exception = exception { + $foo_obj->get(1.1); + }; + + like( + $exception, + qr/The index passed to get must be an integer/, + "get takes integer argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "get takes integer argument"); + + is( + $exception->argument, + 1.1, + "get takes integer argument"); + + is( + $exception->method_name, + "get", + "get takes integer argument"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->first( $arg ); + }; + + like( + $exception, + qr/The argument passed to first must be a code reference/, + "an ArrayRef passed to first"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to first"); + + is( + $exception->method_name, + "first", + "an ArrayRef passed to first"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to first"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to first"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to first"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->first_index( $arg ); + }; + + like( + $exception, + qr/The argument passed to first_index must be a code reference/, + "an ArrayRef passed to first_index"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to first_index"); + + is( + $exception->method_name, + "first_index", + "an ArrayRef passed to first_index"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to first_index"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to first_index"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to first_index"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->grep( $arg ); + }; + + like( + $exception, + qr/The argument passed to grep must be a code reference/, + "an ArrayRef passed to grep"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to grep"); + + is( + $exception->method_name, + "grep", + "an ArrayRef passed to grep"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to grep"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to grep"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to grep"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->join( $arg ); + }; + + like( + $exception, + qr/The argument passed to join must be a string/, + "an ArrayRef passed to join"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to join"); + + is( + $exception->method_name, + "join", + "an ArrayRef passed to join"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to join"); + + is( + $exception->type_of_argument, + "string", + "an ArrayRef passed to join"); + + is( + $exception->type, + "Str", + "an ArrayRef passed to join"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->map( $arg ); + }; + + like( + $exception, + qr/The argument passed to map must be a code reference/, + "an ArrayRef passed to map"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to map"); + + is( + $exception->method_name, + "map", + "an ArrayRef passed to map"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to map"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to map"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to map"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->natatime( $arg ); + }; + + like( + $exception, + qr/The n value passed to natatime must be an integer/, + "an ArrayRef passed to natatime"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to natatime"); + + is( + $exception->method_name, + "natatime", + "an ArrayRef passed to natatime"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to natatime"); + + is( + $exception->type_of_argument, + "integer", + "an ArrayRef passed to natatime"); + + is( + $exception->type, + "Int", + "an ArrayRef passed to natatime"); + + $exception = exception { + $foo_obj->natatime( 1, $arg ); + }; + + like( + $exception, + qr/The second argument passed to natatime must be a code reference/, + "an ArrayRef passed to natatime"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to natatime"); + + is( + $exception->method_name, + "natatime", + "an ArrayRef passed to natatime"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to natatime"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to natatime"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to natatime"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->reduce( $arg ); + }; + + like( + $exception, + qr/The argument passed to reduce must be a code reference/, + "an ArrayRef passed to reduce"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to reduce"); + + is( + $exception->method_name, + "reduce", + "an ArrayRef passed to reduce"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to reduce"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to reduce"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to reduce"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->sort( $arg ); + }; + + like( + $exception, + qr/The argument passed to sort must be a code reference/, + "an ArrayRef passed to sort"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to sort"); + + is( + $exception->method_name, + "sort", + "an ArrayRef passed to sort"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to sort"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to sort"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to sort"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->sort_in_place( $arg ); + }; + + like( + $exception, + qr/The argument passed to sort_in_place must be a code reference/, + "an ArrayRef passed to sort_in_place"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to sort_in_place"); + + is( + $exception->method_name, + "sort_in_place", + "an ArrayRef passed to sort_in_place"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to sort_in_place"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to sort_in_place"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to sort_in_place"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->splice( 1, $arg ); + }; + + like( + $exception, + qr/The length argument passed to splice must be an integer/, + "an ArrayRef passed to splice"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to splice"); + + is( + $exception->method_name, + "splice", + "an ArrayRef passed to splice"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to splice"); + + is( + $exception->type_of_argument, + "integer", + "an ArrayRef passed to splice"); + + is( + $exception->type, + "Int", + "an ArrayRef passed to splice"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-collection.t b/t/exceptions/moose-meta-method-accessor-native-collection.t new file mode 100644 index 0000000..00efb25 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-collection.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Bar; + use Moose; + + has 'foo' => ( + is => 'rw', + isa => 'ArrayRef[Int]', + traits => ['Array'], + handles => { push => 'push'} + ); +} + +my $bar_obj = Bar->new; +{ + my $exception = exception { + $bar_obj->push(1.2); + }; + + like( + $exception, + qr/A new member value for foo does not pass its type constraint because: Validation failed for 'Int' with value 1.2/, + "trying to push a Float(1.2) to ArrayRef[Int]"); + + isa_ok( + $exception, + 'Moose::Exception::ValidationFailedForInlineTypeConstraint', + "trying to push a Float(1.2) to ArrayRef[Int]"); + + is( + $exception->attribute_name, + "foo", + "trying to push a Float(1.2) to ArrayRef[Int]"); + + is( + $exception->class_name, + "Bar", + "trying to push a Float(1.2) to ArrayRef[Int]"); + + is( + $exception->value, + 1.2, + "trying to push a Float(1.2) to ArrayRef[Int]"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-grep.t b/t/exceptions/moose-meta-method-accessor-native-grep.t new file mode 100644 index 0000000..6f20cb4 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-grep.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'ArrayRef', + traits => ['Array'], + handles => { + grep => 'grep' + }, + required => 1 + ); + } + + my $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->grep( $arg ); + }; + + like( + $exception, + qr/The argument passed to grep must be a code reference/, + "an ArrayRef passed to grep"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to grep"); + + is( + $exception->method_name, + "grep", + "an ArrayRef passed to grep"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to grep"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to grep"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to grep"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-hash-set.t b/t/exceptions/moose-meta-method-accessor-native-hash-set.t new file mode 100644 index 0000000..46f82cf --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-hash-set.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'HashRef', + traits => ['Hash'], + handles => { + set => 'set', + }, + required => 1 + ); + } +} + +my $foo_obj = Foo->new( foo => { 1 => "one"} ); + +{ + my $exception = exception { + $foo_obj->set(1 => "foo", "bar"); + }; + + like( + $exception, + qr/You must pass an even number of arguments to set/, + "odd number of arguments passed to set"); + + isa_ok( + $exception, + 'Moose::Exception::MustPassEvenNumberOfArguments', + "odd number of arguments passed to set"); + + is( + $exception->method_name, + "set", + "odd number of arguments passed to set"); +} + +{ + my $exception = exception { + $foo_obj->set(undef, "foo"); + }; + + like( + $exception, + qr/Hash keys passed to set must be defined/, + "undef is passed to set"); + + isa_ok( + $exception, + 'Moose::Exception::UndefinedHashKeysPassedToMethod', + "undef is passed to set"); + + is( + $exception->method_name, + "set", + "undef is passed to set"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-hash.t b/t/exceptions/moose-meta-method-accessor-native-hash.t new file mode 100644 index 0000000..26105cb --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-hash.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'HashRef', + traits => ['Hash'], + handles => { + exists => 'exists' + }, + required => 1 + ); + } + + my $foo_obj = Foo->new( foo => { 1 => "one"} ); + my $arg = undef; + + my $exception = exception { + $foo_obj->exists( undef ); + }; + + like( + $exception, + qr/The key passed to exists must be a defined value/, + "an undef is passed to exists"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an undef is passed to exists"); + + is( + $exception->method_name, + "exists", + "an undef is passed to exists"); + + is( + $exception->argument, + $arg, + "an undef is passed to exists"); + + is( + $exception->type_of_argument, + "defined value", + "an undef is passed to exists"); + + is( + $exception->type, + "Defined", + "an undef is passed to exists"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-string-match.t b/t/exceptions/moose-meta-method-accessor-native-string-match.t new file mode 100644 index 0000000..9ec9ce8 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-string-match.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + match => 'match' + }, + required => 1 + ); +} + +my $foo_obj = Foo->new( foo => 'hello' ); + +{ + my $arg = [12]; + my $exception = exception { + $foo_obj->match( $arg ); + }; + + like( + $exception, + qr/The argument passed to match must be a string or regexp reference/, + "an Array Ref passed to match"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an Array Ref passed to match"); + + is( + $exception->argument, + $arg, + "an Array Ref passed to match"); + + is( + $exception->type_of_argument, + "string or regexp reference", + "an Array Ref passed to match"); + + is( + $exception->method_name, + "match", + "an Array Ref passed to match"); + + is( + $exception->type, + "Str|RegexpRef", + "an Array Ref passed to match"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-string-replace.t b/t/exceptions/moose-meta-method-accessor-native-string-replace.t new file mode 100644 index 0000000..2ae1cb1 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-string-replace.t @@ -0,0 +1,110 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + replace => 'replace' + }, + required => 1 + ); +} + +my $foo_obj = Foo->new( foo => 'hello' ); + +{ + my $arg = [123]; + my $exception = exception { + $foo_obj->replace($arg); + }; + + like( + $exception, + qr/The first argument passed to replace must be a string or regexp reference/, + "an Array ref passed to replace"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an Array ref passed to replace"); + + is( + $exception->argument, + $arg, + "an Array ref passed to replace"); + + is( + $exception->ordinal, + "first", + "an Array ref passed to replace"); + + is( + $exception->type_of_argument, + "string or regexp reference", + "an Array ref passed to replace"); + + is( + $exception->method_name, + "replace", + "an Array ref passed to replace"); + + is( + $exception->type, + "Str|RegexpRef", + "an Array ref passed to replace"); +} + +{ + my $arg = [123]; + my $exception = exception { + $foo_obj->replace('h', $arg); + }; + + like( + $exception, + qr/The second argument passed to replace must be a string or code reference/, + "an Array ref passed to replace"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an Array ref passed to replace"); + + is( + $exception->argument, + $arg, + "an Array ref passed to replace"); + + is( + $exception->ordinal, + "second", + "an Array ref passed to replace"); + + is( + $exception->type_of_argument, + "string or code reference", + "an Array ref passed to replace"); + + is( + $exception->method_name, + "replace", + "an Array ref passed to replace"); + + is( + $exception->type, + "Str|CodeRef", + "an Array ref passed to replace"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-string-substr.t b/t/exceptions/moose-meta-method-accessor-native-string-substr.t new file mode 100644 index 0000000..38c9fdf --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-string-substr.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + substr => 'substr' + }, + required => 1 + ); +} + +my $foo_obj = Foo->new( foo => 'hello' ); + +{ + my $exception = exception { + $foo_obj->substr(1.1); + }; + + like( + $exception, + qr/The first argument passed to substr must be an integer/, + "substr takes integer as its first argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "substr takes integer as its first argument"); + + is( + $exception->argument, + 1.1, + "substr takes integer as its first argument"); + + is( + $exception->ordinal, + "first", + "substr takes integer as its first argument"); + + is( + $exception->type_of_argument, + "integer", + "substr takes integer as its first argument"); + + is( + $exception->method_name, + "substr", + "substr takes integer as its first argument"); + + is( + $exception->type, + "Int", + "substr takes integer as its first argument"); +} + +{ + my $exception = exception { + $foo_obj->substr(1, 1.2); + }; + + like( + $exception, + qr/The second argument passed to substr must be an integer/, + "substr takes integer as its second argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "substr takes integer as its second argument"); + + is( + $exception->argument, + 1.2, + "substr takes integer as its second argument"); + + is( + $exception->ordinal, + "second", + "substr takes integer as its second argument"); + + is( + $exception->type_of_argument, + "integer", + "substr takes integer as its second argument"); + + is( + $exception->method_name, + "substr", + "substr takes integer as its second argument"); + + is( + $exception->type, + "Int", + "substr takes integer as its second argument"); +} + +{ + my $arg = [122]; + my $exception = exception { + $foo_obj->substr(1, 2, $arg); + }; + + like( + $exception, + qr/The third argument passed to substr must be a string/, + "substr takes string as its third argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "substr takes string as its third argument"); + + is( + $exception->argument, + $arg, + "substr takes string as its third argument"); + + is( + $exception->ordinal, + "third", + "substr takes string as its third argument"); + + is( + $exception->type_of_argument, + "string", + "substr takes string as its third argument"); + + is( + $exception->method_name, + "substr", + "substr takes string as its third argument"); + + is( + $exception->type, + "Str", + "substr takes string as its third argument"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native.t b/t/exceptions/moose-meta-method-accessor-native.t new file mode 100644 index 0000000..4afc1af --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native.t @@ -0,0 +1,138 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + substr => 'substr', + }, + required => 1 + ); + } + + my $foo_obj = Foo->new( foo => 'hello' ); + + my $exception = exception { + $foo_obj->substr(1,2,3,3); + }; + + like( + $exception, + qr/Cannot call substr with more than 3 arguments/, + "substr doesn't take 4 arguments"); + + isa_ok( + $exception, + 'Moose::Exception::MethodExpectsFewerArgs', + "substr doesn't take 4 arguments"); + + is( + $exception->method_name, + "substr", + "substr doesn't take 4 arguments"); + + is( + $exception->maximum_args, + 3, + "substr doesn't take 4 arguments"); +} + +{ + { + package Bar; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + substr => 'substr', + }, + required => 1 + ); + } + + my $foo_obj = Bar->new( foo => 'hello' ); + + my $exception = exception { + $foo_obj->substr; + }; + + like( + $exception, + qr/Cannot call substr without at least 1 argument/, + "substr expects atleast 1 argument"); + + isa_ok( + $exception, + 'Moose::Exception::MethodExpectsMoreArgs', + "substr expects atleast 1 argument"); + + is( + $exception->method_name, + "substr", + "substr expects atleast 1 argument"); + + is( + $exception->minimum_args, + 1, + "substr expects atleast 1 argument"); +} + +{ + { + package Bar2; + use Moose; + with 'Moose::Meta::Method::Accessor::Native::Reader'; + + sub _return_value { + return 1; + } + + sub _get_value { + return 1 + } + + sub _inline_store_value { + return 1; + } + + sub _eval_environment { + return 1; + } + } + + my $exception = exception { + Bar2->new( curried_arguments => 'xyz' ); + }; + + like( + $exception, + qr/You must supply a curried_arguments which is an ARRAY reference/, + "curried arguments is 'xyz'"); + + isa_ok( + $exception, + 'Moose::Exception::MustSupplyArrayRefAsCurriedArguments', + "curried arguments is 'xyz'"); + + is( + $exception->class_name, + "Bar2", + "curried arguments is 'xyz'"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor.t b/t/exceptions/moose-meta-method-accessor.t new file mode 100644 index 0000000..f42f4d2 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor.t @@ -0,0 +1,55 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + extends 'Moose::Meta::Method::Accessor'; + } + + my $attr = Class::MOP::Attribute->new("bar"); + Foo->meta->add_attribute($attr); + + my $foo; + my $exception = exception { + $foo = Foo->new( name => "new", + package_name => "Foo", + is_inline => 1, + attribute => $attr, + accessor_type => "writer" + ); + }; + + like( + $exception, + qr/\QCould not generate inline writer because : Could not create writer for 'bar' because Can't locate object method "_eval_environment" via package "Class::MOP::Attribute"/, + "cannot generate writer"); + + isa_ok( + $exception->error, + "Moose::Exception::CouldNotCreateWriter", + "cannot generate writer"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "cannot generate writer"); + + is( + $exception->error->attribute_name, + 'bar', + "cannot generate writer"); + + is( + ref($exception->error->instance), + "Foo", + "cannot generate writer"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-augmented.t b/t/exceptions/moose-meta-method-augmented.t new file mode 100644 index 0000000..c9d9677 --- /dev/null +++ b/t/exceptions/moose-meta-method-augmented.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + package Foo; + use Moose; + + augment 'foo' => sub {}; + }; + + like( + $exception, + qr/You cannot augment 'foo' because it has no super method/, + "'Foo' has no super class"); + + isa_ok( + $exception, + "Moose::Exception::CannotAugmentNoSuperMethod", + "'Foo' has no super class"); + + is( + $exception->method_name, + 'foo', + "'Foo' has no super class"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-constructor.t b/t/exceptions/moose-meta-method-constructor.t new file mode 100644 index 0000000..1780fda --- /dev/null +++ b/t/exceptions/moose-meta-method-constructor.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Constructor->new( options => (1,2,3)); + }; + + like( + $exception, + qr/You must pass a hash of options/, + "options is not a HASH ref"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAHashOfOptions", + "options is not a HASH ref"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Constructor->new( options => {}); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "package_name and name are not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "package_name and name are not given"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-delegation.t b/t/exceptions/moose-meta-method-delegation.t new file mode 100644 index 0000000..5da32e7 --- /dev/null +++ b/t/exceptions/moose-meta-method-delegation.t @@ -0,0 +1,173 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Moose::Meta::Method::Delegation->new; + }; + + like( + $exception, + qr/You must supply an attribute to construct with/, + "no attribute is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAnAttributeToConstructWith", + "no attribute is given"); +} + +{ + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => "foo" ); + }; + + like( + $exception, + qr/\QYou must supply an attribute which is a 'Moose::Meta::Attribute' instance/, + "attribute is not an instance of Moose::Meta::Attribute"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAMooseMetaAttributeInstance", + "attribute is not an instance of Moose::Meta::Attribute"); +} + +{ + my $attr = Moose::Meta::Attribute->new("foo"); + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => $attr ); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "package_name and name are not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "package_name and name are not given"); +} + +{ + my $attr = Moose::Meta::Attribute->new("foo"); + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => $attr, package_name => "Foo", name => "Foo" ); + }; + + like( + $exception, + qr/You must supply a delegate_to_method which is a method name or a CODE reference/, + "delegate_to_method is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyADelegateToMethod", + "delegate_to_method is not given"); +} + +{ + my $attr = Moose::Meta::Attribute->new("foo"); + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => $attr, + package_name => "Foo", + name => "Foo", + delegate_to_method => sub {}, + curried_arguments => {} ); + }; + + like( + $exception, + qr/You must supply a curried_arguments which is an ARRAY reference/, + "curried_arguments not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyArrayRefAsCurriedArguments", + "curried_arguments not given"); +} + +{ + { + package BadClass; + use Moose; + + has 'foo' => ( + is => 'ro', + handles => { get_count => 'count' } + ); + } + + my $object = BadClass->new; + + my $exception = exception { + $object->get_count; + }; + + like( + $exception, + qr/Cannot delegate get_count to count because the value of foo is not defined/, + "foo is not set"); + + isa_ok( + $exception, + "Moose::Exception::AttributeValueIsNotDefined", + "foo is not set"); + + is( + $exception->instance, + $object, + "foo is not set"); + + is( + $exception->attribute->name, + "foo", + "foo is not set"); +} + +{ + { + package BadClass2; + use Moose; + + has 'foo' => ( + is => 'ro', + handles => { get_count => 'count' } + ); + } + + my $array = [12]; + my $object = BadClass2->new( foo => $array ); + my $exception = exception { + $object->get_count; + }; + + like( + $exception, + qr/\QCannot delegate get_count to count because the value of foo is not an object (got '$array')/, + "value of foo is an ARRAY ref"); + #Cannot delegate get_count to count because the value of foo is not an object (got 'ARRAY(0x223f578)') + + isa_ok( + $exception, + "Moose::Exception::AttributeValueIsNotAnObject", + "value of foo is an ARRAY ref"); + + is( + $exception->given_value, + $array, + "value of foo is an ARRAY ref"); + + is( + $exception->attribute->name, + "foo", + "value of foo is an ARRAY ref"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-destructor.t b/t/exceptions/moose-meta-method-destructor.t new file mode 100644 index 0000000..6e72061 --- /dev/null +++ b/t/exceptions/moose-meta-method-destructor.t @@ -0,0 +1,94 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Destructor->new( options => (1,2,3)); + }; + + like( + $exception, + qr/You must pass a hash of options/, + "options is not a HASH ref"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAHashOfOptions", + "options is not a HASH ref"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Destructor->new( options => {}); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "package_name and name are not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "package_name and name are not given"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Destructor->is_needed("foo"); + }; + + like( + $exception, + qr/The is_needed method expected a metaclass object as its arugment/, + "'foo' is not a metaclass"); + + isa_ok( + $exception, + "Moose::Exception::MethodExpectedAMetaclassObject", + "'foo' is not a metaclass"); + + is( + $exception->metaclass, + 'foo', + "'foo' is not a metaclass"); +} + +{ + { + package TestClass; + use Moose; + } + + { + package SubClassDestructor; + use Moose; + extends 'Moose::Meta::Method::Destructor'; + + sub _generate_DEMOLISHALL { + return "print 'xyz"; # this is an intentional syntax error + } + } + + my $methodDestructor; + my $exception = exception { + $methodDestructor = SubClassDestructor->new( name => "xyz", package_name => "Xyz", options => {}, metaclass => TestClass->meta); + }; + + like( + $exception, + qr/Could not eval the destructor/, + "syntax error in the return value of _generate_DEMOLISHALL"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotEvalDestructor", + "syntax error in the return value of _generate_DEMOLISHALL"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-overridden.t b/t/exceptions/moose-meta-method-overridden.t new file mode 100644 index 0000000..a0831d6 --- /dev/null +++ b/t/exceptions/moose-meta-method-overridden.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + package Foo; + use Moose; + + override foo => sub {} + }; + + like( + $exception, + qr/You cannot override 'foo' because it has no super method/, + "Foo class is not extending any class"); + + isa_ok( + $exception, + "Moose::Exception::CannotOverrideNoSuperMethod", + "Foo class is not extending any class"); + + is( + $exception->class, + "Moose::Meta::Method::Overridden", + "Foo class is not extending any class"); + + is( + $exception->method_name, + "foo", + "Foo class is not extending any class"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application-rolesummation.t b/t/exceptions/moose-meta-role-application-rolesummation.t new file mode 100644 index 0000000..faa56c5 --- /dev/null +++ b/t/exceptions/moose-meta-role-application-rolesummation.t @@ -0,0 +1,215 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo1; + use Moose::Role; + excludes 'Bar1'; + } + + { + package Bar1; + use Moose::Role; + } + + my $exception = exception { + package CompositeRole; + use Moose::Role; + with 'Foo1', 'Bar1'; + }; + + like( + $exception, + qr/\QConflict detected: Role Foo1 excludes role 'Bar1'/, + "role Foo1 excludes role Bar1"); + + isa_ok( + $exception, + "Moose::Exception::RoleExclusionConflict", + "role Foo1 excludes role Bar1"); + + is( + $exception->role_name, + "Bar1", + "role Foo1 excludes role Bar1"); + + is_deeply( + $exception->roles, + ["Foo1"], + "role Foo1 excludes role Bar1"); + + { + package Baz1; + use Moose::Role; + excludes 'Bar1'; + } + + $exception = exception { + package CompositeRole1; + use Moose::Role; + with 'Foo1', 'Bar1', 'Baz1'; + }; + + like( + $exception, + qr/\QConflict detected: Roles Foo1, Baz1 exclude role 'Bar1'/, + "role Foo1 & Baz1 exclude role Bar1"); + + isa_ok( + $exception, + "Moose::Exception::RoleExclusionConflict", + "role Foo1 & Baz1 exclude role Bar1"); + + is( + $exception->role_name, + "Bar1", + "role Foo1 & Baz1 exclude role Bar1"); + + is_deeply( + $exception->roles, + ["Foo1", 'Baz1'], + "role Foo1 & Baz1 exclude role Bar1"); +} + +{ + { + package Foo2; + use Moose::Role; + + has 'foo' => ( isa => 'Int' ); + } + + { + package Bar2; + use Moose::Role; + + has 'foo' => ( isa => 'Int' ); + } + + my $exception = exception { + package CompositeRole2; + use Moose::Role; + with 'Foo2', 'Bar2'; + }; + + like( + $exception, + qr/\QWe have encountered an attribute conflict with 'foo' during role composition. This attribute is defined in both Foo2 and Bar2. This is a fatal error and cannot be disambiguated./, + "role Foo2 & Bar2, both have an attribute named foo"); + + isa_ok( + $exception, + "Moose::Exception::AttributeConflictInSummation", + "role Foo2 & Bar2, both have an attribute named foo"); + + is( + $exception->role_name, + "Foo2", + "role Foo2 & Bar2, both have an attribute named foo"); + + is( + $exception->second_role_name, + "Bar2", + "role Foo2 & Bar2, both have an attribute named foo"); + + is( + $exception->attribute_name, + "foo", + "role Foo2 & Bar2, both have an attribute named foo"); +} + +{ + { + package Foo3; + use Moose::Role; + + sub foo {} + } + + { + package Bar3; + use Moose::Role; + + override 'foo' => sub {} + } + + my $exception = exception { + package CompositeRole3; + use Moose::Role; + with 'Foo3', 'Bar3'; + }; + + like( + $exception, + qr/\QRole 'Foo3|Bar3' has encountered an 'override' method conflict during composition (A local method of the same name has been found). This is a fatal error./, + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInSummation", + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); + + my @role_names = $exception->role_names; + my $role_names = join "|", @role_names; + is( + $role_names, + "Foo3|Bar3", + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); + + is( + $exception->method_name, + "foo", + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); +} + +{ + { + package Foo4; + use Moose::Role; + + override 'foo' => sub {}; + } + + { + package Bar4; + use Moose::Role; + + override 'foo' => sub {}; + } + + my $exception = exception { + package CompositeRole4; + use Moose::Role; + with 'Foo4', 'Bar4'; + }; + + like( + $exception, + qr/\QWe have encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "role Foo4 & Bar4, both are overriding the same method 'foo'"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInSummation", + "role Foo4 & Bar4, both are overriding the same method 'foo'"); + + my @role_names = $exception->role_names; + my $role_names = join "|", @role_names; + is( + $role_names, + "Foo4|Bar4", + "role Foo4 & Bar4, both are overriding the same method 'foo'"); + + is( + $exception->method_name, + "foo", + "role Foo4 & Bar4, both are overriding the same method 'foo'"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application-toclass.t b/t/exceptions/moose-meta-role-application-toclass.t new file mode 100644 index 0000000..2a32e38 --- /dev/null +++ b/t/exceptions/moose-meta-role-application-toclass.t @@ -0,0 +1,432 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +use Moose::Util 'find_meta'; + +{ + { + package BarRole; + use Moose::Role; + } + + { + package RoleExcludingBarRole; + use Moose::Role; + excludes 'BarRole'; + } + + my $exception = exception { + { + package FooClass; + use Moose; + + with 'RoleExcludingBarRole'; + with 'BarRole'; + } + }; + + like( + $exception, + qr/\QConflict detected: FooClass excludes role 'BarRole'/, + 'class FooClass excludes Role BarRole'); + + isa_ok( + $exception, + "Moose::Exception::ConflictDetectedInCheckRoleExclusionsInToClass", + 'class FooClass excludes Role BarRole'); + + is( + $exception->class_name, + "FooClass", + 'class FooClass excludes Role BarRole'); + + is( + find_meta($exception->class_name), + FooClass->meta, + 'class FooClass excludes Role BarRole'); + + is( + $exception->role_name, + "BarRole", + 'class FooClass excludes Role BarRole'); + + is( + find_meta($exception->role_name), + BarRole->meta, + 'class FooClass excludes Role BarRole'); +} + +{ + { + package BarRole2; + use Moose::Role; + excludes 'ExcludedRole2'; + } + + { + package ExcludedRole2; + use Moose::Role; + } + + my $exception = exception { + { + package FooClass2; + use Moose; + + with 'ExcludedRole2'; + with 'BarRole2'; + } + }; + + like( + $exception, + qr/\QThe class FooClass2 does the excluded role 'ExcludedRole2'/, + 'Class FooClass2 does Role ExcludedRole2'); + + isa_ok( + $exception, + "Moose::Exception::ClassDoesTheExcludedRole", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + $exception->role_name, + "BarRole2", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + find_meta($exception->role_name), + BarRole2->meta, + 'Class FooClass2 does Role ExcludedRole2'); + + is( + $exception->excluded_role_name, + "ExcludedRole2", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + find_meta($exception->excluded_role_name), + ExcludedRole2->meta, + 'Class FooClass2 does Role ExcludedRole2'); + + is( + $exception->class_name, + "FooClass2", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + find_meta($exception->class_name), + FooClass2->meta, + 'Class FooClass2 does Role ExcludedRole2'); +} + +{ + { + package Foo5; + use Moose::Role; + + sub foo5 { "foo" } + } + + my $exception = exception { + { + package Bar5; + use Moose; + with 'Foo5' => { + -alias => { foo5 => 'foo_in_bar' } + }; + + sub foo_in_bar { "test in foo" } + } + }; + + like( + $exception, + qr/\QCannot create a method alias if a local method of the same name exists/, + "Class Bar5 already has a method named foo_in_bar"); + + isa_ok( + $exception, + "Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresentInClass", + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->role_name, + "Foo5", + "Class Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->role_name), + Foo5->meta, + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->class_name, + "Bar5", + "Class Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->class_name), + Bar5->meta, + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->aliased_method_name, + "foo_in_bar", + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->method->name, + "foo5", + "Class Bar5 already has a method named foo_in_bar"); +} + +{ + { + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + } + + { + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + } + + { + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + } + + my $exception = exception { + { + package My::Foo::Class::Broken; + use Moose; + + with 'Foo::Role', + 'Bar::Role', + 'Baz::Role' => { -excludes => 'foo' }; + } + }; + + like( + $exception, + qr/\QDue to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + isa_ok( + $exception, + "Moose::Exception::MethodNameConflictInRoles", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + $exception->class_name, + "My::Foo::Class::Broken", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + find_meta($exception->class_name), + My::Foo::Class::Broken->meta, + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + $exception->get_method_at(0)->name, + "foo", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + $exception->get_method_at(0)->roles_as_english_list, + "'Bar::Role' and 'Foo::Role'", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); +} + +{ + { + package Foo2::Role; + use Moose::Role; + + sub foo { 'Foo2::Role::foo' } + sub bar { 'Foo2::Role::bar' } + } + + { + package Bar2::Role; + use Moose::Role; + + sub foo { 'Bar2::Role::foo' } + sub bar { 'Bar2::Role::bar' } + } + + { + package Baz2::Role; + use Moose::Role; + + sub foo { 'Baz2::Role::foo' } + sub bar { 'Baz2::Role::bar' } + } + + my $exception = exception { + { + package My::Foo::Class::Broken2; + use Moose; + + with 'Foo2::Role', + 'Bar2::Role', + 'Baz2::Role'; + } + }; + + like( + $exception, + qr/\QDue to method name conflicts in roles 'Bar2::Role' and 'Foo2::Role', the methods 'bar' and 'foo' must be implemented or excluded by 'My::Foo::Class::Broken2'/, + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + isa_ok( + $exception, + "Moose::Exception::MethodNameConflictInRoles", + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + is( + $exception->class_name, + "My::Foo::Class::Broken2", + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + is( + find_meta($exception->class_name), + My::Foo::Class::Broken2->meta, + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + is( + $exception->get_method_at(0)->roles_as_english_list, + "'Bar2::Role' and 'Foo2::Role'", + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); +} + +{ + { + package Foo3::Role; + use Moose::Role; + requires 'foo'; + } + + { + package Bar3::Role; + use Moose::Role; + } + + { + package Baz3::Role; + use Moose::Role; + } + + my $exception = exception { + { + package My::Foo::Class::Broken3; + use Moose; + with 'Foo3::Role', + 'Bar3::Role', + 'Baz3::Role'; + } + }; + + like( + $exception, + qr/\Q'Foo3::Role|Bar3::Role|Baz3::Role' requires the method 'foo' to be implemented by 'My::Foo::Class::Broken3'/, + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + isa_ok( + $exception, + "Moose::Exception::RequiredMethodsNotImplementedByClass", + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + $exception->class_name, + "My::Foo::Class::Broken3", + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + find_meta($exception->class_name), + My::Foo::Class::Broken3->meta, + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + $exception->role_name, + 'Foo3::Role|Bar3::Role|Baz3::Role', + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + $exception->get_method_at(0)->name, + "foo", + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); +} + +{ + BEGIN { + package ExportsFoo; + use Sub::Exporter -setup => { + exports => ['foo'], + }; + + sub foo { 'FOO' } + + $INC{'ExportsFoo.pm'} = 1; + } + + { + package Foo4::Role; + use Moose::Role; + requires 'foo'; + } + + my $exception = exception { + { + package Class; + use Moose; + use ExportsFoo 'foo'; + with 'Foo4::Role'; + } + }; + + my $methodName = "\\&foo"; + + like( + $exception, + qr/\Q'Foo4::Role' requires the method 'foo' to be implemented by 'Class'. If you imported functions intending to use them as methods, you need to explicitly mark them as such, via Class->meta->add_method(foo => $methodName)/, + "foo is required by Foo4::Role and imported by Class"); + + isa_ok( + $exception, + "Moose::Exception::RequiredMethodsImportedByClass", + "foo is required by Foo4::Role and imported by Class"); + + is( + $exception->class_name, + "Class", + "foo is required by Foo4::Role and imported by Class"); + + is( + find_meta($exception->class_name), + Class->meta, + "foo is required by Foo4::Role and imported by Class"); + + is( + $exception->role_name, + 'Foo4::Role', + "foo is required by Foo4::Role and imported by Class"); + + is( + $exception->get_method_at(0)->name, + "foo", + "foo is required by Foo4::Role and imported by Class"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application-torole.t b/t/exceptions/moose-meta-role-application-torole.t new file mode 100644 index 0000000..cd827f4 --- /dev/null +++ b/t/exceptions/moose-meta-role-application-torole.t @@ -0,0 +1,350 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util 'find_meta'; + +use Moose(); + +{ + { + package Foo; + use Moose::Role; + excludes 'Bar'; + } + + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + Moose::Meta::Role::Application::ToRole->check_role_exclusions( Bar->meta, Foo->meta ); + }; + + like( + $exception, + qr/\QConflict detected: Foo excludes role 'Bar'/, + 'Role Foo excludes Role Bar'); + + isa_ok( + $exception, + "Moose::Exception::ConflictDetectedInCheckRoleExclusions", + 'Role Foo excludes Role Bar'); + + is( + $exception->role_name, + "Foo", + 'Role Foo excludes Role Bar'); + + is( + find_meta($exception->role_name), + Foo->meta, + 'Role Foo excludes Role Bar'); + + is( + $exception->excluded_role_name, + "Bar", + 'Role Foo excludes Role Bar'); + + is( + find_meta($exception->excluded_role_name), + Bar->meta, + 'Role Foo excludes Role Bar'); +} + +{ + { + package Foo2; + use Moose::Role; + excludes 'Bar3'; + } + + { + package Bar2; + use Moose::Role; + with 'Bar3'; + } + + { + package Bar3; + use Moose::Role; + } + + my $exception = exception { + Moose::Meta::Role::Application::ToRole->check_role_exclusions( Foo2->meta, Bar2->meta ); + }; + + like( + $exception, + qr/\QThe role Bar2 does the excluded role 'Bar3'/, + 'Role Bar2 does Role Bar3'); + + isa_ok( + $exception, + "Moose::Exception::RoleDoesTheExcludedRole", + 'Role Bar2 does Role Bar3'); + + is( + $exception->second_role_name, + "Foo2", + 'Role Bar2 does Role Bar3'); + + is( + find_meta($exception->second_role_name), + Foo2->meta, + 'Role Bar2 does Role Bar3'); + + is( + $exception->excluded_role_name, + "Bar3", + 'Role Bar2 does Role Bar3'); + + is( + find_meta($exception->excluded_role_name), + Bar3->meta, + 'Role Bar2 does Role Bar3'); + + is( + $exception->role_name, + "Bar2", + 'Role Bar2 does Role Bar3'); + + is( + find_meta($exception->role_name), + Bar2->meta, + 'Role Bar2 does Role Bar3'); +} + +{ + { + package Foo4; + use Moose::Role; + + has 'foo' => ( + is => 'ro', + isa => 'Int' + ); + } + + { + package Bar4; + use Moose::Role; + + has 'foo' => ( + is => 'ro', + isa => 'Int' + ); + } + + my $exception = exception { + Moose::Meta::Role::Application::ToRole->apply_attributes( Foo4->meta, Bar4->meta ); + }; + + like( + $exception, + qr/\QRole 'Foo4' has encountered an attribute conflict while being composed into 'Bar4'. This is a fatal error and cannot be disambiguated. The conflicting attribute is named 'foo'./, + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + isa_ok( + $exception, + "Moose::Exception::AttributeConflictInRoles", + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + $exception->role_name, + "Foo4", + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + find_meta($exception->role_name), + Foo4->meta, + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + $exception->second_role_name, + "Bar4", + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + find_meta($exception->second_role_name), + Bar4->meta, + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + $exception->attribute_name, + 'foo', + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); +} + +{ + { + package Foo5; + use Moose::Role; + + sub foo5 { "foo" } + } + + my $exception = exception { + { + package Bar5; + use Moose::Role; + with 'Foo5' => { + -alias => { foo5 => 'foo_in_bar' } + }; + + sub foo_in_bar { "test in foo" } + } + }; + + like( + $exception, + qr/\QCannot create a method alias if a local method of the same name exists/, + "Role Bar5 already has a method named foo_in_bar"); + + isa_ok( + $exception, + "Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresent", + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->role_name, + "Bar5", + "Role Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->role_name), + Bar5->meta, + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->role_being_applied_name, + "Foo5", + "Role Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->role_being_applied_name), + Foo5->meta, + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->aliased_method_name, + "foo_in_bar", + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->method->name, + "foo5", + "Role Bar5 already has a method named foo_in_bar"); +} + +{ + { + package Foo6; + use Moose::Role; + + override foo6 => sub { "override foo6" }; + } + + my $exception = exception { + { + package Bar6; + use Moose::Role; + with 'Foo6'; + + sub foo6 { "test in foo6" } + } + }; + + like( + $exception, + qr/\QRole 'Foo6' has encountered an 'override' method conflict during composition (A local method of the same name as been found). This is a fatal error./, + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInComposition", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + $exception->role_name, + "Bar6", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + find_meta($exception->role_name), + Bar6->meta, + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + $exception->role_being_applied_name, + "Foo6", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + find_meta($exception->role_being_applied_name), + Foo6->meta, + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + $exception->method_name, + "foo6", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); +} + +{ + { + package Foo7; + use Moose::Role; + + override foo7 => sub { "override foo7" }; + } + + my $exception = exception { + { + package Bar7; + use Moose::Role; + override foo7 => sub { "override foo7 in Bar7" }; + with 'Foo7'; + } + }; + + like( + $exception, + qr/\QRole 'Foo7' has encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "Roles Foo7 & Bar7, both have override foo7"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInComposition", + "Roles Foo7 & Bar7, both have override foo7"); + + is( + $exception->role_name, + "Bar7", + "Roles Foo7 & Bar7, both have override foo7"); + + is( + find_meta($exception->role_name), + Bar7->meta, + "Roles Foo7 & Bar7, both have override foo7"); + + is( + $exception->role_being_applied_name, + "Foo7", + "Roles Foo7 & Bar7, both have override foo7"); + + is( + find_meta($exception->role_being_applied_name), + Foo7->meta, + "Roles Foo7 & Bar7, both have override foo7"); + + is( + $exception->method_name, + "foo7", + "Roles Foo7 & Bar7, both have override foo7"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application.t b/t/exceptions/moose-meta-role-application.t new file mode 100644 index 0000000..b1ccf62 --- /dev/null +++ b/t/exceptions/moose-meta-role-application.t @@ -0,0 +1,121 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application; + +{ + my $exception = exception { + Moose::Meta::Role::Application->check_role_exclusions; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->check_required_methods; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->check_required_attributes; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_attributes; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_methods; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_override_method_modifiers; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_method_modifiers; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-attribute.t b/t/exceptions/moose-meta-role-attribute.t new file mode 100644 index 0000000..f7c9008 --- /dev/null +++ b/t/exceptions/moose-meta-role-attribute.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Moose::Meta::Role::Attribute->new; + }; + + like( + $exception, + qr/You must provide a name for the attribute/, + "no name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustProvideANameForTheAttribute", + "no name is given"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Attribute->attach_to_role; + }; + + like( + $exception, + qr/\QYou must pass a Moose::Meta::Role instance (or a subclass)/, + "no role is given to attach_to_role"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAMooseMetaRoleInstanceOrSubclass", + "no role is given to attach_to_role"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-composite.t b/t/exceptions/moose-meta-role-composite.t new file mode 100644 index 0000000..05ae6ae --- /dev/null +++ b/t/exceptions/moose-meta-role-composite.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $rolesComp = Moose::Meta::Role::Composite->new(roles => ["foo"]); + }; + + like( + $exception, + qr/\QThe list of roles must be instances of Moose::Meta::Role, not foo/, + "'foo' is not an instance of Moose::Meta::Role"); + + isa_ok( + $exception, + "Moose::Exception::RolesListMustBeInstancesOfMooseMetaRole", + "'foo' is not an instance of Moose::Meta::Role"); + + is( + $exception->role, + "foo", + "'foo' is not an instance of Moose::Meta::Role"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $rolesComp = Moose::Meta::Role::Composite->new(roles => [Foo->meta]); + my $exception = exception { + $rolesComp->add_method; + }; + + like( + $exception, + qr/You must define a method name/, + "no method name given to add_method"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name given to add_method"); + + is( + $exception->instance, + $rolesComp, + "no method name given to add_method"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $rolesComp = Moose::Meta::Role::Composite->new(roles => [Foo->meta]); + my $exception = exception { + $rolesComp->reinitialize; + }; + + like( + $exception, + qr/Moose::Meta::Role::Composite instances can only be reinitialized from an existing metaclass instance/, + "no metaclass instance is given"); + + isa_ok( + $exception, + "Moose::Exception::CannotInitializeMooseMetaRoleComposite", + "no metaclass instance is given"); + + is( + $exception->role_composite, + $rolesComp, + "no metaclass instance is given"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typecoercion-union.t b/t/exceptions/moose-meta-typecoercion-union.t new file mode 100644 index 0000000..3712165 --- /dev/null +++ b/t/exceptions/moose-meta-typecoercion-union.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose; +use Moose::Util::TypeConstraints; + +{ + my $exception = exception { + Moose::Meta::TypeCoercion::Union->new( type_constraint => find_type_constraint("Str") ); + }; + + like( + $exception, + qr/\QYou can only create a Moose::Meta::TypeCoercion::Union for a Moose::Meta::TypeConstraint::Union, not a Str/, + "'Str' is not a Moose::Meta::TypeConstraint::Union"); + + isa_ok( + $exception, + "Moose::Exception::NeedsTypeConstraintUnionForTypeCoercionUnion", + "'Str' is not a Moose::Meta::TypeConstraint::Union"); + + is( + $exception->type_name, + "Str", + "'Str' is not a Moose::Meta::TypeConstraint::Union"); +} + +{ + union 'StringOrInt', [qw( Str Int )]; + my $type = find_type_constraint("StringOrInt"); + my $tt = Moose::Meta::TypeCoercion::Union->new( type_constraint => $type ); + + my $exception = exception { + $tt->add_type_coercions("ArrayRef"); + }; + + like( + $exception, + qr/Cannot add additional type coercions to Union types/, + "trying to add ArrayRef to a Moose::Meta::TypeCoercion::Union object"); + + isa_ok( + $exception, + "Moose::Exception::CannotAddAdditionalTypeCoercionsToUnion", + "trying to add ArrayRef to a Moose::Meta::TypeCoercion::Union object"); + + is( + $exception->type_coercion_union_object, + $tt, + "trying to add ArrayRef to a Moose::Meta::TypeCoercion::Union object"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typecoercion.t b/t/exceptions/moose-meta-typecoercion.t new file mode 100644 index 0000000..50a73ab --- /dev/null +++ b/t/exceptions/moose-meta-typecoercion.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + subtype 'typeInt', + as 'Int'; + + my $exception = exception { + coerce 'typeInt', + from 'xyz'; + }; + + like( + $exception, + qr/\QCould not find the type constraint (xyz) to coerce from/, + "xyz is not a valid type constraint"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotFindTypeConstraintToCoerceFrom", + "xyz is not a valid type constraint"); + + is( + $exception->constraint_name, + "xyz", + "xyz is not a valid type constraint"); +} + +{ + subtype 'typeInt', + as 'Int'; + + my $exception = exception { + coerce 'typeInt', from 'Int', via { "123" }; + coerce 'typeInt', from 'Int', via { 12 }; + }; + + like( + $exception, + qr/\QA coercion action already exists for 'Int'/, + "coercion already exists"); + + isa_ok( + $exception, + "Moose::Exception::CoercionAlreadyExists", + "coercion already exists"); + + is( + $exception->constraint_name, + "Int", + "coercion already exists"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-enum.t b/t/exceptions/moose-meta-typeconstraint-enum.t new file mode 100644 index 0000000..4028212 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-enum.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $method = Moose::Meta::TypeConstraint::Enum->new( values => []); + }; + + like( + $exception, + qr/You must have at least one value to enumerate through/, + "an Array ref of zero length is given as values"); + + isa_ok( + $exception, + "Moose::Exception::MustHaveAtLeastOneValueToEnumerate", + "an Array ref of zero length is given as values"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::TypeConstraint::Enum->new( values => [undef]); + }; + + like( + $exception, + qr/Enum values must be strings, not undef/, + "undef is given to values"); + + isa_ok( + $exception, + "Moose::Exception::EnumValuesMustBeString", + "undef is given to values"); +} + +{ + my $arrayRef = [1,2,3]; + my $exception = exception { + my $method = Moose::Meta::TypeConstraint::Enum->new( values => [$arrayRef]); + }; + + like( + $exception, + qr/\QEnum values must be strings, not '$arrayRef'/, + "an array ref is given instead of a string"); + #Enum values must be strings, not 'ARRAY(0x191d1b8)' + + isa_ok( + $exception, + "Moose::Exception::EnumValuesMustBeString", + "an array ref is given instead of a string"); + + is( + $exception->value, + $arrayRef, + "an array ref is given instead of a string"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-parameterizable.t b/t/exceptions/moose-meta-typeconstraint-parameterizable.t new file mode 100644 index 0000000..5ae75fc --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-parameterizable.t @@ -0,0 +1,67 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + my $t = find_type_constraint('ArrayRef'); + my $intType = find_type_constraint("Int"); + my $type = Moose::Meta::TypeConstraint::Parameterizable->new( name => 'xyz', parent => $t); + + my $exception = exception { + $type->generate_inline_for( $intType, '$_[0]'); + }; + + like( + $exception, + qr/Can't generate an inline constraint for Int, since none was defined/, + "no inline constraint was defined for xyz"); + + isa_ok( + $exception, + "Moose::Exception::CannotGenerateInlineConstraint", + "no inline constraint was defined for xyz"); + + is( + $exception->type_name, + "Int", + "no inline constraint was defined for xyz"); + + is( + $exception->parameterizable_type_object_name, + $type->name, + "no inline constraint was defined for xyz"); +} + +{ + my $parameterizable = subtype 'parameterizable_arrayref', as 'ArrayRef[Float]'; + my $int = find_type_constraint('Int'); + my $exception = exception { + my $from_parameterizable = $parameterizable->parameterize("Int"); + }; + + like( + $exception, + qr/Int is not a subtype of Float/, + "Int is not a subtype of Float"); + + isa_ok( + $exception, + "Moose::Exception::ParameterIsNotSubtypeOfParent", + "Int is not a subtype of Float"); + + is( + $exception->type_name, + $parameterizable, + "Int is not a subtype of Float"); + + is( + $exception->type_parameter, + $int, + "Int is not a subtype of Float"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-parameterized.t b/t/exceptions/moose-meta-typeconstraint-parameterized.t new file mode 100644 index 0000000..ae685a8 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-parameterized.t @@ -0,0 +1,83 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + Moose::Meta::TypeConstraint::Parameterized->new( name => "TestType" ); + }; + + like( + $exception, + qr/You cannot create a Higher Order type without a type parameter/, + "type_parameter not given"); + + isa_ok( + $exception, + 'Moose::Exception::CannotCreateHigherOrderTypeWithoutATypeParameter', + "type_parameter not given"); + + is( + $exception->type_name, + "TestType", + "type_parameter not given"); +} + +{ + my $exception = exception { + Moose::Meta::TypeConstraint::Parameterized->new( name => "TestType2", + type_parameter => 'Int' + ); + }; + + like( + $exception, + qr/The type parameter must be a Moose meta type/, + "'Int' is not a Moose::Meta::TypeConstraint"); + + isa_ok( + $exception, + 'Moose::Exception::TypeParameterMustBeMooseMetaType', + "'Int' is not a Moose::Meta::TypeConstraint"); + + is( + $exception->type_name, + "TestType2", + "'Int' is not a Moose::Meta::TypeConstraint"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Int[Xyz]', + ); + }; + + like( + $exception, + qr/\QThe Int[Xyz] constraint cannot be used, because Int doesn't subtype or coerce from a parameterizable type./, + "invalid isa given to foo"); + + isa_ok( + $exception, + 'Moose::Exception::TypeConstraintCannotBeUsedForAParameterizableType', + "invalid isa given to foo"); + + is( + $exception->type_name, + "Int[Xyz]", + "invalid isa given to foo"); + + is( + $exception->parent_type_name, + 'Int', + "invalid isa given to foo"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-registry.t b/t/exceptions/moose-meta-typeconstraint-registry.t new file mode 100644 index 0000000..fa20375 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-registry.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose; + +{ + my $tr = Moose::Meta::TypeConstraint::Registry->new(); + + my $exception = exception { + $tr->add_type_constraint('xyz'); + }; + + like( + $exception, + qr!No type supplied / type is not a valid type constraint!, + "'xyz' is not a Moose::Meta::TypeConstraint"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidTypeConstraint', + "'xyz' is not a Moose::Meta::TypeConstraint"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint.t b/t/exceptions/moose-meta-typeconstraint.t new file mode 100644 index 0000000..71e87d1 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint.t @@ -0,0 +1,139 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose(); + +# tests for type coercions +{ + subtype 'HexNum' => as 'Int', where { /[a-f0-9]/i }; + my $type_object = find_type_constraint 'HexNum'; + + my $exception = exception { + $type_object->coerce; + }; + + like( + $exception, + qr/Cannot coerce without a type coercion/, + "You cannot coerce a type unless coercion is supported by that type"); + + is( + $exception->type_name, + 'HexNum', + "You cannot coerce a type unless coercion is supported by that type"); + + isa_ok( + $exception, + "Moose::Exception::CoercingWithoutCoercions", + "You cannot coerce a type unless coercion is supported by that type"); +} + +{ + my $exception = exception { + Moose::Meta::TypeConstraint->new( message => "foo"); + }; + + like( + $exception, + qr/The 'message' parameter must be a coderef/, + "'foo' is not a CODE ref"); + + isa_ok( + $exception, + "Moose::Exception::MessageParameterMustBeCodeRef", + "'foo' is not a CODE ref"); +} + +{ + subtype 'NotInlinable', + as 'Str', + where { $_ !~ /Q/ }; + my $not_inlinable = find_type_constraint('NotInlinable'); + + my $exception = exception { + $not_inlinable->_inline_check('$foo'); + }; + + like( + $exception, + qr/Cannot inline a type constraint check for NotInlinable/, + "cannot inline NotInlinable"); + + isa_ok( + $exception, + "Moose::Exception::CannotInlineTypeConstraintCheck", + "cannot inline NotInlinable"); + + is( + $exception->type_name, + "NotInlinable", + "cannot inline NotInlinable"); + + is( + find_type_constraint( $exception->type_name ), + $not_inlinable, + "cannot inline NotInlinable"); +} + +{ + my $exception = exception { + Moose::Meta::TypeConstraint->new(name => "FooTypeConstraint", constraint => undef) + }; + + like( + $exception, + qr/Could not compile type constraint 'FooTypeConstraint' because no constraint check/, + "constraint is set to undef"); + + isa_ok( + $exception, + "Moose::Exception::NoConstraintCheckForTypeConstraint", + "constraint is set to undef"); + + is( + $exception->type_name, + "FooTypeConstraint", + "constraint is set to undef"); +} + +{ + subtype 'OnlyPositiveInts', + as 'Int', + where { $_ > 1 }; + my $onlyposint = find_type_constraint('OnlyPositiveInts'); + + my $exception = exception { + $onlyposint->assert_valid( -123 ); + }; + + like( + $exception, + qr/Validation failed for 'OnlyPositiveInts' with value -123/, + "-123 is not valid for OnlyPositiveInts"); + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForTypeConstraint", + "-123 is not valid for OnlyPositiveInts"); + + is( + $exception->type->name, + "OnlyPositiveInts", + "-123 is not valid for OnlyPositiveInts"); + + is( + $exception->type, + $onlyposint, + "-123 is not valid for OnlyPositiveInts"); + + is( + $exception->value, + -123, + "-123 is not valid for OnlyPositiveInts"); +} + +done_testing; diff --git a/t/exceptions/moose-role.t b/t/exceptions/moose-role.t new file mode 100644 index 0000000..a2200fb --- /dev/null +++ b/t/exceptions/moose-role.t @@ -0,0 +1,321 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +use Moose::Util 'find_meta'; + +{ + my $exception = exception { + package Bar; + use Moose::Role; + extends 'Foo'; + }; + + like( + $exception, + qr/\QRoles do not support 'extends' (you can use 'with' to specialize a role)/, + "Roles do not support extends"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportExtends", + "Roles do not support extends"); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + requires; + }; + + like( + $exception, + qr/Must specify at least one method/, + "requires expects atleast one method name"); + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneMethod", + "requires expects atleast one method name"); + + is( + $exception->role_name, + 'Bar', + 'requires expects atleast one method name'); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + excludes; + }; + + like( + $exception, + qr/Must specify at least one role/, + "excludes expects atleast one role name"); + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRole", + "excludes expects atleast one role name"); + + is( + $exception->role_name, + 'Bar', + 'excludes expects atleast one role name'); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + inner; + }; + + like( + $exception, + qr/Roles cannot support 'inner'/, + "Roles do not support 'inner'"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportInner", + "Roles do not support 'inner'"); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + augment 'foo' => sub {}; + }; + + like( + $exception, + qr/Roles cannot support 'augment'/, + "Roles do not support 'augment'"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportAugment", + "Roles do not support 'augment'"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose::Role; + has 'bar' => ( + is => + ); + } + }; + + like( + $exception, + qr/\QUsage: has 'name' => ( key => value, ... )/, + "has takes a hash"); + + isa_ok( + $exception, + "Moose::Exception::InvalidHasProvidedInARole", + "has takes a hash"); + + is( + $exception->attribute_name, + 'bar', + "has takes a hash"); + + is( + $exception->role_name, + 'Foo1', + "has takes a hash"); +} + +{ + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta; + }; + + like( + $exception, + qr/Cannot call init_meta without specifying a for_class/, + "for_class is not given"); + + isa_ok( + $exception, + "Moose::Exception::InitMetaRequiresClass", + "for_class is not given"); +} + +{ + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo2', metaclass => 'Foo2' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo2 must be loaded. (Perhaps you forgot to 'use Foo2'?)/, + "Foo2 is not loaded"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassNotLoaded", + "Foo2 is not loaded"); + + is( + $exception->class_name, + "Foo2", + "Foo2 is not loaded"); +} + +{ + { + package Foo3; + use Moose; + } + + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo3', metaclass => 'Foo3' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo3 must be a subclass of Moose::Meta::Role./, + "Foo3 is a Moose::Role"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassMustBeASubclassOfMooseMetaRole", + "Foo3 is a Moose::Role"); + + is( + $exception->role_name, + "Foo3", + "Foo3 is a Moose::Role"); +} + +{ + { + package Foo3; + use Moose; + } + + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo3' )); + }; + + my $foo3 = Foo3->meta; + + like( + $exception, + qr/\QFoo3 already has a metaclass, but it does not inherit Moose::Meta::Role ($foo3). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role./, + "Foo3 is a Moose class"); + #Foo3 already has a metaclass, but it does not inherit Moose::Meta::Role (Moose::Meta::Class=HASH(0x2d5d160)). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role. + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsAClassNotASubclassOfGivenMetaclass", + "Foo3 is a Moose class"); + + is( + $exception->class_name, + "Foo3", + "Foo3 is a Moose class"); + + is( + find_meta($exception->class_name), + Foo3->meta, + "Foo3 is a Moose class"); + + is( + $exception->metaclass, + "Moose::Meta::Role", + "Foo3 is a Moose class"); +} + +{ + my $foo; + { + $foo = Class::MOP::Class->create("Foo4"); + } + + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo4' )); + }; + + like( + $exception, + qr/\QFoo4 already has a metaclass, but it does not inherit Moose::Meta::Role ($foo)./, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + #Foo4 already has a metaclass, but it does not inherit Moose::Meta::Role (Class::MOP::Class=HASH(0x2c385a8)). + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + + is( + $exception->class_name, + "Foo4", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + + is( + find_meta( $exception->class_name ), + $foo, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + + is( + $exception->metaclass, + "Moose::Meta::Role", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); +} + +{ + my $exception = exception { + package Foo; + use Moose::Role; + + before qr/foo/; + }; + + like( + $exception, + qr/\QRoles do not currently support regex references for before method modifiers/, + "a regex reference is given to before"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportRegexReferencesForMethodModifiers", + "a regex reference is given to before"); + + is( + $exception->role_name, + "Foo", + "a regex reference is given to before"); + + is( + find_meta($exception->role_name), + Foo->meta, + "a regex reference is given to before"); + + is( + $exception->modifier_type, + "before", + "a regex reference is given to before"); +} + +done_testing; diff --git a/t/exceptions/moose-util-metarole.t b/t/exceptions/moose-util-metarole.t new file mode 100644 index 0000000..11e30af --- /dev/null +++ b/t/exceptions/moose-util-metarole.t @@ -0,0 +1,129 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + { + package Foo; + use Moose; + } + + my $foo = Foo->new; + my $blessed_foo = blessed $foo; + my %args = ( "for" => $foo ); + + my $exception = exception { + Moose::Util::MetaRole::apply_metaroles( %args ); + }; + + my $message = "When using Moose::Util::MetaRole, " + ."you must pass a Moose class name, role name, metaclass object, or metarole object." + ." You passed $foo, and we resolved this to a $blessed_foo object."; + + like( + $exception, + qr/\Q$message/, + "$foo is an object, not a class"); + #When using Moose::Util::MetaRole, you must pass a Moose class name, role name, metaclass object, or metarole object. You passed Foo=HASH(0x16adb58), and we resolved this to a Foo object. + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgPassedToMooseUtilMetaRole', + "$foo is an object, not a class"); + + is( + $exception->argument, + $foo, + "$foo is an object, not a class"); +} + +{ + my $array_ref = [1, 2, 3]; + my %args = ( "for" => $array_ref ); + + my $exception = exception { + Moose::Util::MetaRole::apply_metaroles( %args ); + }; + + my $message = "When using Moose::Util::MetaRole, " + ."you must pass a Moose class name, role name, metaclass object, or metarole object." + ." You passed $array_ref, and this did not resolve to a metaclass or metarole." + ." Maybe you need to call Moose->init_meta to initialize the metaclass first?"; + + like( + $exception, + qr/\Q$message/, + "an Array ref is passed to apply_metaroles"); + #When using Moose::Util::MetaRole, you must pass a Moose class name, role name, metaclass object, or metarole object. You passed ARRAY(0x21eb868), and this did not resolve to a metaclass or metarole. Maybe you need to call Moose->init_meta to initialize the metaclass first? + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgPassedToMooseUtilMetaRole', + "an Array ref is passed to apply_metaroles"); + + is( + $exception->argument, + $array_ref, + "an Array ref is passed to apply_metaroles"); +} + +{ + my %args = ( "for" => undef ); + + my $exception = exception { + Moose::Util::MetaRole::apply_metaroles( %args ); + }; + + my $message = "When using Moose::Util::MetaRole, " + ."you must pass a Moose class name, role name, metaclass object, or metarole object." + ." You passed undef, and this did not resolve to a metaclass or metarole." + ." Maybe you need to call Moose->init_meta to initialize the metaclass first?"; + + like( + $exception, + qr/\Q$message/, + "undef passed to apply_metaroles"); + #When using Moose::Util::MetaRole, you must pass a Moose class name, role name, metaclass object, or metarole object. You passed undef, and this did not resolve to a metaclass or metarole. Maybe you need to call Moose->init_meta to initialize the metaclass first? + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgPassedToMooseUtilMetaRole', + "undef passed to apply_metaroles"); + + is( + $exception->argument, + undef, + "undef passed to apply_metaroles"); +} + +{ + { + package Foo::Role; + use Moose::Role; + } + + my %args = ('for' => "Foo::Role" ); + + my $exception = exception { + Moose::Util::MetaRole::apply_base_class_roles( %args ); + }; + + like( + $exception, + qr/\QYou can only apply base class roles to a Moose class, not a role./, + "Moose::Util::MetaRole::apply_base_class_roles expects a class for 'for'"); + + isa_ok( + $exception, + 'Moose::Exception::CannotApplyBaseClassRolesToRole', + "Moose::Util::MetaRole::apply_base_class_roles expects a class for 'for'"); + + is( + $exception->role_name, + 'Foo::Role', + "Moose::Util::MetaRole::apply_base_class_roles expects a class for 'for'"); +} + +done_testing; diff --git a/t/exceptions/moose-util-typeconstraints.t b/t/exceptions/moose-util-typeconstraints.t new file mode 100644 index 0000000..22ad7f2 --- /dev/null +++ b/t/exceptions/moose-util-typeconstraints.t @@ -0,0 +1,171 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +my $x = "123"; + +{ + my $default = [1, 2, 3]; + my $exception = exception { + match_on_type $x => ( 'Int' => + sub { "Action for Int"; } => + $default + ); + }; + + like( + $exception, + qr/\QDefault case must be a CODE ref, not $default/, + "an ArrayRef is passed as a default"); + #Default case must be a CODE ref, not ARRAY(0x14f6fc8) + + isa_ok( + $exception, + 'Moose::Exception::DefaultToMatchOnTypeMustBeCodeRef', + "an ArrayRef is passed as a default"); + + is( + $exception->default_action, + $default, + "an ArrayRef is passed as a default"); + + is( + $exception->to_match, + $x, + "an ArrayRef is passed as a default"); +} + +{ + my $exception = exception { + match_on_type $x => ( 'doesNotExist' => sub { "Action for Int"; } ); + }; + + like( + $exception, + qr/\QCannot find or parse the type 'doesNotExist'/, + "doesNotExist is not a valid type"); + + isa_ok( + $exception, + 'Moose::Exception::CannotFindTypeGivenToMatchOnType', + "doesNotExist is not a valid type"); + + is( + $exception->type, + "doesNotExist", + "doesNotExist is not a valid type"); + + is( + $exception->to_match, + $x, + "doesNotExist is not a valid type"); +} + +{ + my $action = [1, 2, 3]; + my $exception = exception { + match_on_type $x => ( Int => $action ); + }; + + like( + $exception, + qr/\QMatch action must be a CODE ref, not $action/, + "an ArrayRef is given as action"); + #Match action must be a CODE ref, not ARRAY(0x27a0748) + + isa_ok( + $exception, + 'Moose::Exception::MatchActionMustBeACodeRef', + "an ArrayRef is given as action"); + + is( + $exception->type_name, + "Int", + "an ArrayRef is given as action"); + + is( + $exception->to_match, + $x, + "an ArrayRef is given as action"); + + is( + $exception->action, + $action, + "an ArrayRef is given as action"); +} + +{ + my $exception = exception { + match_on_type $x => ( 'ArrayRef' => sub { "Action for Int"; } ); + }; + + like( + $exception, + qr/\QNo cases matched for $x/, + "$x is not an ArrayRef"); + #No cases matched for 123 + + isa_ok( + $exception, + 'Moose::Exception::NoCasesMatched', + "$x is not an ArrayRef"); + + is( + $exception->to_match, + $x, + "$x is not an ArrayRef"); +} + +{ + { + package TestType; + use Moose; + extends 'Moose::Meta::TypeConstraint'; + + sub name { + undef; + } + } + + my $tt = TestType->new; + my $exception = exception { + register_type_constraint( $tt ); + }; + + like( + $exception, + qr/can't register an unnamed type constraint/, + "name has been set to undef for TestType"); + + isa_ok( + $exception, + 'Moose::Exception::CannotRegisterUnnamedTypeConstraint', + "name has been set to undef for TestType"); +} + +{ + my $exception = exception { + union 'StrUndef', 'Str | Undef |'; + }; + + like( + $exception, + qr/\Q'Str | Undef |' didn't parse (parse-pos=11 and str-length=13)/, + "cannot parse 'Str| Undef |'"); + + isa_ok( + $exception, + 'Moose::Exception::CouldNotParseType', + "cannot parse 'Str| Undef |'"); + + is( + $exception->type, + 'Str | Undef |', + "cannot parse 'Str| Undef |'"); +} + +done_testing; diff --git a/t/exceptions/moose.t b/t/exceptions/moose.t new file mode 100644 index 0000000..fc5f0e5 --- /dev/null +++ b/t/exceptions/moose.t @@ -0,0 +1,173 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util 'find_meta'; + +# tests for extends without arguments +{ + my $exception = exception { + package SubClassNoSuperClass; + use Moose; + extends; + }; + + like( + $exception, + qr/Must derive at least one class/, + "extends requires at least one argument"); + + isa_ok( + $exception, + 'Moose::Exception::ExtendsMissingArgs', + "extends requires at least one argument"); +} + +{ + my $exception = exception { + use Moose; + Moose->init_meta; + }; + + like( + $exception, + qr/Cannot call init_meta without specifying a for_class/, + "for_class is not given"); + + isa_ok( + $exception, + "Moose::Exception::InitMetaRequiresClass", + "for_class is not given"); +} + +{ + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo2', metaclass => 'Foo2' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo2 must be loaded. (Perhaps you forgot to 'use Foo2'?)/, + "Foo2 is not loaded"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassNotLoaded", + "Foo2 is not loaded"); + + is( + $exception->class_name, + "Foo2", + "Foo2 is not loaded"); +} + +{ + { + package Foo3; + use Moose::Role; + } + + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo3', metaclass => 'Foo3' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo3 must be a subclass of Moose::Meta::Class./, + "Foo3 is a Moose::Role"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassMustBeASubclassOfMooseMetaClass", + "Foo3 is a Moose::Role"); + + is( + $exception->class_name, + "Foo3", + "Foo3 is a Moose::Role"); +} + +{ + { + package Foo3; + use Moose::Role; + } + + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo3' )); + }; + + my $foo3 = Foo3->meta; + + like( + $exception, + qr/\QFoo3 already has a metaclass, but it does not inherit Moose::Meta::Class ($foo3). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role./, + "Foo3 is a Moose::Role"); + #Foo3 already has a metaclass, but it does not inherit Moose::Meta::Class (Moose::Meta::Role=HASH(0x29d3c78)). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role. + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsARoleNotASubclassOfGivenMetaclass", + "Foo3 is a Moose::Role"); + + is( + $exception->role_name, + "Foo3", + "Foo3 is a Moose::Role"); + + is( + find_meta($exception->role_name), + Foo3->meta, + "Foo3 is a Moose::Role"); + + is( + $exception->metaclass, + "Moose::Meta::Class", + "Foo3 is a Moose::Role"); +} + +{ + my $foo; + { + use Moose; + $foo = Class::MOP::Class->create("Foo4"); + } + + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo4' )); + }; + + like( + $exception, + qr/\QFoo4 already has a metaclass, but it does not inherit Moose::Meta::Class ($foo)./, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + #Foo4 already has a metaclass, but it does not inherit Moose::Meta::Class (Class::MOP::Class=HASH(0x278a4a0)). + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + + is( + $exception->class_name, + "Foo4", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + + is( + find_meta($exception->class_name), + $foo, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + + is( + $exception->metaclass, + "Moose::Meta::Class", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); +} + +done_testing; diff --git a/t/exceptions/object.t b/t/exceptions/object.t new file mode 100644 index 0000000..71b78d4 --- /dev/null +++ b/t/exceptions/object.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# tests for SingleParamsToNewMustBeHashRef +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->new("hello") + }; + + like( + $exception, + qr/^\QSingle parameters to new() must be a HASH ref/, + "A single non-hashref arg to a constructor throws an error"); + + isa_ok( + $exception, + "Moose::Exception::SingleParamsToNewMustBeHashRef", + "A single non-hashref arg to a constructor throws an error"); +} + +# tests for DoesRequiresRoleName +{ + { + package Foo; + use Moose; + } + + my $foo = Foo->new; + + my $exception = exception { + $foo->does; + }; + + like( + $exception, + qr/^\QYou must supply a role name to does()/, + "Cannot call does() without a role name"); + + isa_ok( + $exception, + "Moose::Exception::DoesRequiresRoleName", + "Cannot call does() without a role name"); + + is( + $exception->class_name, + "Foo", + "Cannot call does() without a role name"); + + $exception = exception { + Foo->does; + }; + + like( + $exception, + qr/^\QYou must supply a role name to does()/, + "Cannot call does() without a role name"); + + isa_ok( + $exception, + "Moose::Exception::DoesRequiresRoleName", + "Cannot call does() without a role name"); + + is( + $exception->class_name, + "Foo", + "Cannot call does() without a role name"); +} + +done_testing; diff --git a/t/exceptions/overload.t b/t/exceptions/overload.t new file mode 100644 index 0000000..8d01e35 --- /dev/null +++ b/t/exceptions/overload.t @@ -0,0 +1,15 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Exception; + +my $exception = Moose::Exception->new(message => 'barf!'); + +like($exception, qr/barf/, 'stringification for regex works'); + +ok($exception ne 'oh hai', 'direct string comparison works'); + +ok($exception, 'exception can be treated as a boolean'); + +done_testing; diff --git a/t/exceptions/rt-92818.t b/t/exceptions/rt-92818.t new file mode 100644 index 0000000..b504841 --- /dev/null +++ b/t/exceptions/rt-92818.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# https://rt.cpan.org/Ticket/Display.html?id=92818 + +{ + package Parent; + use Moose; + has x => ( + is => 'rw', + required => 1, + ); +} + +{ + my $e = exception { my $obj = Parent->new }; + ok( + $e->isa('Moose::Exception::AttributeIsRequired'), + 'got the right exception', + ) + or note 'got exception ', ref($e), ': ', $e->message; +} + +{ + package Child; + use Moose; + extends 'Parent'; +} + +# the exception produced should be AttributeIsRequired, however +# AttributeIsRequired was throwing the exception ClassNamesDoNotMatch. + +{ + my $e = exception { my $obj = Child->new }; + ok( + $e->isa('Moose::Exception::AttributeIsRequired'), + 'got the right exception', + ) + or note 'got exception ', ref($e), ': ', $e->message; +} + +done_testing; diff --git a/t/exceptions/rt-94795.t b/t/exceptions/rt-94795.t new file mode 100644 index 0000000..2742407 --- /dev/null +++ b/t/exceptions/rt-94795.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# https://rt.cpan.org/Ticket/Display.html?id=94795 + +# the exception produced should be AttributeIsRequired, however +# AttributeIsRequired was throwing the exception ClassNamesDoNotMatch. + +{ + package AAA; + use Moose; + has my_attr => ( + is => 'ro', + required => 1, + ); +} + +{ + package BBB; + use Moose; + extends qw/AAA/; +} + +my $e = exception { BBB->new }; +ok( + $e->isa('Moose::Exception::AttributeIsRequired'), + 'got the right exception', +) +or note 'got exception ', ref($e), ': ', $e->message; + +done_testing; diff --git a/t/exceptions/stringify.t b/t/exceptions/stringify.t new file mode 100644 index 0000000..7a7f0c4 --- /dev/null +++ b/t/exceptions/stringify.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Try::Tiny; + +{ + my $e; + { + package Foo; + use Moose; + use Try::Tiny; + + try { + has '+foo' => ( is => 'ro' ); + } + catch { + $e = $_; + }; + } + + ok( $e, q{got an exception from a bad has '+foo' declaration} ); + like( + $e->as_string, + qr/\QCould not find an attribute by the name of 'foo' to inherit from in Foo/, + 'stringification includes the error message' + ); + like( + $e->as_string, + qr/\s+Moose::has/, + 'stringification includes the call to Moose::has' + ); + unlike( + $e->as_string, + qr/Moose::Meta/, + 'stringification does not include internal calls to Moose meta classes' + ); + + try { + Foo->meta->clone_object( [] ); + } + catch { + $e = $_; + }; + + like( + $e->as_string, + qr/Class::MOP::Class::clone_object/, + 'exception include first Class::MOP::Class frame' + ); + unlike( + $e->as_string, + qr/Class::MOP::Mixin::_throw_exception/, + 'exception does not include internal calls toClass::MOP::Class meta classes' + ); +} + +local $ENV{MOOSE_FULL_EXCEPTION} = 1; +{ + my $e; + { + package Bar; + use Moose; + use Try::Tiny; + + try { + has '+foo' => ( is => 'ro' ); + } + catch { + $e = $_; + }; + } + + ok( $e, q{got an exception from a bad has '+foo' declaration} ); + like( + $e->as_string, + qr/\QCould not find an attribute by the name of 'foo' to inherit from in Bar/, + 'stringification includes the error message' + ); + like( + $e->as_string, + qr/\s+Moose::has/, + 'stringification includes the call to Moose::has' + ); + like( + $e->as_string, + qr/Moose::Meta/, + 'stringification includes internal calls to Moose meta classes when MOOSE_FULL_EXCEPTION env var is true' + ); + + + try { + Foo->meta->clone_object( [] ); + } + catch { + $e = $_; + }; + + like( + $e->as_string, + qr/Class::MOP::Class::clone_object/, + 'exception include first Class::MOP::Class frame' + ); + like( + $e->as_string, + qr/Class::MOP::Mixin::_throw_exception/, + 'exception includes internal calls toClass::MOP::Class meta classes when MOOSE_FULL_EXCEPTION env var is true' + ); +} + +done_testing; diff --git a/t/exceptions/traits.t b/t/exceptions/traits.t new file mode 100644 index 0000000..2d2fad0 --- /dev/null +++ b/t/exceptions/traits.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# this test taken from MooseX::ABC t/immutable.t, where it broke with Moose 2.1207 + +{ + package ABC; + use Moose::Role; + around new => sub { + my $orig = shift; + my $class = shift; + my $meta = Class::MOP::class_of($class); + $meta->throw_error("$class is abstract, it cannot be instantiated"); + $class->$orig(@_); + }; +} +{ + package MyApp::Base; + use Moose; + with 'ABC'; + __PACKAGE__->meta->make_immutable(inline_constructor => 0); +} + + +like( + exception { MyApp::Base->new }, + qr/MyApp::Base is abstract, it cannot be instantiated/, + 'instantiating abstract classes fails', +); + +done_testing; diff --git a/t/exceptions/typeconstraints.t b/t/exceptions/typeconstraints.t new file mode 100644 index 0000000..6c1e4e6 --- /dev/null +++ b/t/exceptions/typeconstraints.t @@ -0,0 +1,293 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +# tests for type/subtype name contain invalid characters +{ + my $exception = exception { + subtype 'Foo-Baz' => as 'Item' + }; + + like( + $exception, + qr/contains invalid characters/, + "Type names cannot contain a dash (via subtype sugar)"); + + isa_ok( + $exception, + "Moose::Exception::InvalidNameForType", + "Type names cannot contain a dash (via subtype sugar)"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_type_constraint_union(); + }; + + like( + $exception, + qr/You must pass in at least 2 type names to make a union/, + "Moose::Util::TypeConstraints::create_type_constraint_union takes atleast two arguments"); + + isa_ok( + $exception, + "Moose::Exception::UnionTakesAtleastTwoTypeNames", + "Moose::Util::TypeConstraints::create_type_constraint_union takes atleast two arguments"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_type_constraint_union('foo','bar'); + }; + + like( + $exception, + qr/\QCould not locate type constraint (foo) for the union/, + "invalid typeconstraint given to Moose::Util::TypeConstraints::create_type_constraint_union"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotLocateTypeConstraintForUnion", + "invalid typeconstraint given to Moose::Util::TypeConstraints::create_type_constraint_union"); + + is( + $exception->type_name, + 'foo', + "invalid typeconstraint given to Moose::Util::TypeConstraints::create_type_constraint_union"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_parameterized_type_constraint("Foo"); + }; + + like( + $exception, + qr/\QCould not parse type name (Foo) correctly/, + "'Foo' is not a valid type constraint name"); + + isa_ok( + $exception, + "Moose::Exception::InvalidTypeGivenToCreateParameterizedTypeConstraint", + "'Foo' is not a valid type constraint name"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_parameterized_type_constraint("Foo[Int]"); + }; + + like( + $exception, + qr/\QCould not locate the base type (Foo)/, + "'Foo' is not a valid base type constraint name"); + + isa_ok( + $exception, + "Moose::Exception::InvalidBaseTypeGivenToCreateParameterizedTypeConstraint", + "'Foo' is not a valid base type constraint name"); +} + +{ + { + package Foo1; + use Moose::Role; + } + + my $exception = exception { + Moose::Util::TypeConstraints::class_type("Foo1"); + }; + + like( + $exception, + qr/\QThe type constraint 'Foo1' has already been created in Moose::Role and cannot be created again in main/, + "there is an already defined role of name 'Foo1'"); + + isa_ok( + $exception, + "Moose::Exception::TypeConstraintIsAlreadyCreated", + "there is an already defined role of name 'Foo1'"); + + is( + $exception->type_name, + 'Foo1', + "there is an already defined role of name 'Foo1'"); + + is( + (find_type_constraint($exception->type_name))->_package_defined_in, + 'Moose::Role', + "there is an already defined role of name 'Foo1'"); + + is( + $exception->package_defined_in, + 'main', + "there is an already defined role of name 'Foo1'"); +} + +{ + { + package Foo2; + use Moose; + } + + my $exception = exception { + Moose::Util::TypeConstraints::role_type("Foo2"); + }; + + like( + $exception, + qr/\QThe type constraint 'Foo2' has already been created in Moose and cannot be created again in main/, + "there is an already defined class of name 'Foo2'"); + + isa_ok( + $exception, + "Moose::Exception::TypeConstraintIsAlreadyCreated", + "there is an already defined class of name 'Foo2'"); + + is( + $exception->type_name, + 'Foo2', + "there is an already defined class of name 'Foo2'"); + + is( + (find_type_constraint($exception->type_name))->_package_defined_in, + 'Moose', + "there is an already defined class of name 'Foo2'"); + + is( + $exception->package_defined_in, + 'main', + "there is an already defined class of name 'Foo2'"); +} + +{ + my $exception = exception { + subtype 'Foo'; + }; + + like( + $exception, + qr/A subtype cannot consist solely of a name, it must have a parent/, + "no parent given to subtype"); + + isa_ok( + $exception, + "Moose::Exception::NoParentGivenToSubtype", + "no parent given to subtype"); + + is( + $exception->name, + 'Foo', + "no parent given to subtype"); +} + +{ + my $exception = exception { + enum [1,2,3], "foo"; + }; + + like( + $exception, + qr/\Qenum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?/, + "enum expects either a name & an array or only an array"); + + isa_ok( + $exception, + "Moose::Exception::EnumCalledWithAnArrayRefAndAdditionalArgs", + "enum expects either a name & an array or only an array"); +} + +{ + my $exception = exception { + union [1,2,3], "foo"; + }; + + like( + $exception, + qr/union called with an array reference and additional arguments/, + "union expects either a name & an array or only an array"); + + isa_ok( + $exception, + "Moose::Exception::UnionCalledWithAnArrayRefAndAdditionalArgs", + "union expects either a name & an array or only an array"); +} + +{ + { + package Foo3; + use Moose; + } + + my $exception = exception { + Moose::Util::TypeConstraints::type("Foo3"); + }; + + like( + $exception, + qr/\QThe type constraint 'Foo3' has already been created in Moose and cannot be created again in main/, + "there is an already defined class of name 'Foo3'"); + + isa_ok( + $exception, + "Moose::Exception::TypeConstraintIsAlreadyCreated", + "there is an already defined class of name 'Foo3'"); + + is( + $exception->type_name, + 'Foo3', + "there is an already defined class of name 'Foo3'"); + + is( + find_type_constraint($exception->type_name)->_package_defined_in, + 'Moose', + "there is an already defined class of name 'Foo3'"); + + is( + $exception->package_defined_in, + 'main', + "there is an already defined class of name 'Foo3'"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::coerce "Foo"; + }; + + like( + $exception, + qr/Cannot find type 'Foo', perhaps you forgot to load it/, + "'Foo' is not a valid type"); + + isa_ok( + $exception, + "Moose::Exception::CannotFindType", + "'Foo' is not a valid type"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::add_parameterizable_type "Foo"; + }; + + like( + $exception, + qr/Type must be a Moose::Meta::TypeConstraint::Parameterizable not Foo/, + "'Foo' is not a parameterizable type"); + + isa_ok( + $exception, + "Moose::Exception::AddParameterizableTypeTakesParameterizableType", + "'Foo' is not a parameterizable type"); + + is( + $exception->type_name, + "Foo", + "'Foo' is not a parameterizable type"); +} + +done_testing; diff --git a/t/exceptions/util.t b/t/exceptions/util.t new file mode 100644 index 0000000..551e773 --- /dev/null +++ b/t/exceptions/util.t @@ -0,0 +1,188 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util qw/apply_all_roles add_method_modifier/; + +{ + { + package TestClass; + use Moose; + } + + my $test_object = TestClass->new; + + my $exception = exception { + apply_all_roles( $test_object ); + }; + + like( + $exception, + qr/\QMust specify at least one role to apply to $test_object/, + "apply_all_roles takes an object and a role to apply"); + #Must specify at least one role to apply to TestClass=HASH(0x2bee290) + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant", + "apply_all_roles takes an object and a role to apply"); + + my $test_class = TestClass->meta; + + $exception = exception { + apply_all_roles( $test_class ); + }; + + like( + $exception, + qr/\QMust specify at least one role to apply to $test_class/, + "apply_all_roles takes a class and a role to apply"); + #Must specify at least one role to apply to Moose::Meta::Class=HASH(0x1a1f818) + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant", + "apply_all_roles takes a class and a role to apply"); + + { + package TestRole; + use Moose::Role; + } + + my $test_role = TestRole->meta; + + $exception = exception { + apply_all_roles( $test_role ); + }; + + like( + $exception, + qr/\QMust specify at least one role to apply to $test_role/, + "apply_all_roles takes a role and a role to apply"); + #Must specify at least one role to apply to Moose::Meta::Role=HASH(0x1f22d40) + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant", + "apply_all_roles takes a role and a role to apply"); +} + +# tests for class consuming a class, instead of role +{ + my $exception = exception { + package ClassConsumingClass; + use Moose; + use Module::Runtime; + with 'Module::Runtime'; + }; + + like( + $exception, + qr/You can only consume roles, Module::Runtime is not a Moose role/, + "You can't consume a class"); + + isa_ok( + $exception, + 'Moose::Exception::CanOnlyConsumeRole', + "You can't consume a class"); + + $exception = exception { + package foo; + use Moose; + use Module::Runtime; + with 'Not::A::Real::Package'; + }; + + like( + $exception, + qr!Can't locate Not/A/Real/Package\.pm in \@INC!, + "You can't consume a class which doesn't exist"); + + $exception = exception { + package foo; + use Moose; + use Module::Runtime; + with sub {}; + }; + + like( + $exception, + qr/argument is not a module name/, + "You can only consume a module"); +} + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + add_method_modifier(Foo->meta, "before", [{}, sub {"before";}]); + }; + + like( + $exception, + qr/\QMethods passed to before must be provided as a list, arrayref or regex, not HASH/, + "we gave a HashRef to before"); + + isa_ok( + $exception, + "Moose::Exception::IllegalMethodTypeToAddMethodModifier", + "we gave a HashRef to before"); + + is( + ref( $exception->params->[0] ), + "HASH", + "we gave a HashRef to before"); + + is( + $exception->modifier_name, + 'before', + "we gave a HashRef to before"); + + is( + $exception->class_or_object->name, + "Foo", + "we gave a HashRef to before"); +} + +{ + my $exception = exception { + package My::Class; + use Moose; + has 'attr' => ( + is => 'ro', + traits => [qw( Xyz )], + ); + }; + + like( + $exception, + qr/^Can't locate Moose::Meta::Attribute::Custom::Trait::Xyz or Xyz in \@INC \(\@INC contains:/, + "Cannot locate 'Xyz'"); + + isa_ok( + $exception, + "Moose::Exception::CannotLocatePackageInINC", + "Cannot locate 'Xyz'"); + + is( + $exception->type, + "Attribute", + "Cannot locate 'Xyz'"); + + is( + $exception->possible_packages, + 'Moose::Meta::Attribute::Custom::Trait::Xyz or Xyz', + "Cannot locate 'Xyz'"); + + is( + $exception->metaclass_name, + "Xyz", + "Cannot locate 'Xyz'"); +} + +done_testing; diff --git a/t/immutable/apply_roles_to_immutable.t b/t/immutable/apply_roles_to_immutable.t new file mode 100644 index 0000000..206cd16 --- /dev/null +++ b/t/immutable/apply_roles_to_immutable.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + around 'baz' => sub { + my $next = shift; + 'My::Role::baz(' . $next->(@_) . ')'; + }; +} + +{ + package Foo; + use Moose; + + sub baz { 'Foo::baz' } + + __PACKAGE__->meta->make_immutable(debug => 0); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->baz, 'Foo::baz', '... got the right value'); + +is( exception { + My::Role->meta->apply($foo) +}, undef, '... successfully applied the role to immutable instance' ); + +is($foo->baz, 'My::Role::baz(Foo::baz)', '... got the right value'); + +done_testing; diff --git a/t/immutable/buildargs.t b/t/immutable/buildargs.t new file mode 100644 index 0000000..338e520 --- /dev/null +++ b/t/immutable/buildargs.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $self, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return {@args}; + } + + __PACKAGE__->meta->make_immutable; + + package Bar; + use Moose; + + extends qw(Foo); + + __PACKAGE__->meta->make_immutable; +} + +foreach my $class (qw(Foo Bar)) { + is( $class->new->bar, undef, "no args" ); + is( $class->new( bar => 42 )->bar, 42, "normal args" ); + is( $class->new( 37 )->bar, 37, "single arg" ); + { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } +} + +done_testing; diff --git a/t/immutable/constructor_is_not_moose.t b/t/immutable/constructor_is_not_moose.t new file mode 100644 index 0000000..43e9ec9 --- /dev/null +++ b/t/immutable/constructor_is_not_moose.t @@ -0,0 +1,100 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package NotMoose; + + sub new { + my $class = shift; + + return bless { not_moose => 1 }, $class; + } +} + +{ + package Foo; + use Moose; + + extends 'NotMoose'; + + ::stderr_like( + sub { Foo->meta->make_immutable }, + qr/\QNot inlining 'new' for Foo since it is not inheriting the default Moose::Object::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, + 'got a warning that Foo may not have an inlined constructor' + ); +} + +is( + Foo->meta->find_method_by_name('new')->body, + NotMoose->can('new'), + 'Foo->new is inherited from NotMoose' +); + +{ + package Bar; + use Moose; + + extends 'NotMoose'; + + ::stderr_is( + sub { Bar->meta->make_immutable( replace_constructor => 1 ) }, + q{}, + 'no warning when replace_constructor is true' + ); +} + +is( + Bar->meta->find_method_by_name('new')->package_name, + 'Bar', + 'Bar->new is inlined, and not inherited from NotMoose' +); + +{ + package Baz; + use Moose; + + Baz->meta->make_immutable; +} + +{ + package Quux; + use Moose; + + extends 'Baz'; + + ::stderr_is( + sub { Quux->meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package My::Constructor; + use parent 'Moose::Meta::Method::Constructor'; +} + +{ + package CustomCons; + use Moose; + + CustomCons->meta->make_immutable( constructor_class => 'My::Constructor' ); +} + +{ + package Subclass; + use Moose; + + extends 'CustomCons'; + + ::stderr_is( + sub { Subclass->meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +done_testing; diff --git a/t/immutable/constructor_is_wrapped.t b/t/immutable/constructor_is_wrapped.t new file mode 100644 index 0000000..820d7e9 --- /dev/null +++ b/t/immutable/constructor_is_wrapped.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package ModdedNew; + use Moose; + + before 'new' => sub { }; +} + +{ + package Foo; + use Moose; + + extends 'ModdedNew'; + + ::stderr_like( + sub { Foo->meta->make_immutable }, + qr/\QNot inlining 'new' for Foo since it has method modifiers which would be lost if it were inlined/, + 'got a warning that Foo may not have an inlined constructor' + ); +} + +done_testing; diff --git a/t/immutable/default_values.t b/t/immutable/default_values.t new file mode 100644 index 0000000..81c57f7 --- /dev/null +++ b/t/immutable/default_values.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + + package Foo; + use Moose; + + has 'foo' => ( is => 'rw', default => q{'} ); + has 'bar' => ( is => 'rw', default => q{\\} ); + has 'baz' => ( is => 'rw', default => q{"} ); + has 'buz' => ( is => 'rw', default => q{"'\\} ); + has 'faz' => ( is => 'rw', default => qq{\0} ); + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has default values that could break quoting' ); +} + +my $foo = Foo->new; +is( $foo->foo, q{'}, + 'default value for foo attr' ); +is( $foo->bar, q{\\}, + 'default value for bar attr' ); +is( $foo->baz, q{"}, + 'default value for baz attr' ); +is( $foo->buz, q{"'\\}, + 'default value for buz attr' ); +is( $foo->faz, qq{\0}, + 'default value for faz attr' ); + + +# Lazy attrs were never broken, but it doesn't hurt to test that they +# won't be broken by any future changes. +# Also make sure that attributes stay lazy even after being immutable + +{ + + package Bar; + use Moose; + + has 'foo' => ( is => 'rw', default => q{'}, lazy => 1 ); + has 'bar' => ( is => 'rw', default => q{\\}, lazy => 1 ); + has 'baz' => ( is => 'rw', default => q{"}, lazy => 1 ); + has 'buz' => ( is => 'rw', default => q{"'\\}, lazy => 1 ); + has 'faz' => ( is => 'rw', default => qq{\0}, lazy => 1 ); + + { + my $bar = Bar->new; + ::ok(!$bar->meta->get_attribute($_)->has_value($bar), + "Attribute $_ has no value") + for qw(foo bar baz buz faz); + } + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has lazy default values that could break quoting' ); + + { + my $bar = Bar->new; + ::ok(!$bar->meta->get_attribute($_)->has_value($bar), + "Attribute $_ has no value (immutable)") + for(qw(foo bar baz buz faz)); + } + +} + +my $bar = Bar->new; +is( $bar->foo, q{'}, + 'default value for foo attr' ); +is( $bar->bar, q{\\}, + 'default value for bar attr' ); +is( $bar->baz, q{"}, + 'default value for baz attr' ); +is( $bar->buz, q{"'\\}, + 'default value for buz attr' ); +is( $bar->faz, qq{\0}, + 'default value for faz attr' ); + +done_testing; diff --git a/t/immutable/definition_context.t b/t/immutable/definition_context.t new file mode 100644 index 0000000..71482df --- /dev/null +++ b/t/immutable/definition_context.t @@ -0,0 +1,82 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + use Moose::Util::TypeConstraints; + use Carp 'confess'; + subtype 'Death', as 'Int', where { $_ == 1 }; + coerce 'Death', from 'Any', via { confess }; +} + +{ + my ($attr_foo_line, $attr_bar_line, $ctor_line); + { + package Foo; + use Moose; + + has foo => ( + is => 'rw', + isa => 'Death', + coerce => 1, + ); + $attr_foo_line = __LINE__ - 5; + + has bar => ( + accessor => 'baz', + isa => 'Death', + coerce => 1, + ); + $attr_bar_line = __LINE__ - 5; + + __PACKAGE__->meta->make_immutable; + $ctor_line = __LINE__ - 1; + } + + like( + exception { Foo->new(foo => 2) }, + qr/\Qcalled at constructor Foo::new (defined at $0 line $ctor_line)\E/, + "got definition context for the constructor" + ); + + like( + exception { my $f = Foo->new(foo => 1); $f->foo(2) }, + qr/\Qcalled at accessor Foo::foo (defined at $0 line $attr_foo_line)\E/, + "got definition context for the accessor" + ); + + like( + exception { my $f = Foo->new(foo => 1); $f->baz(2) }, + qr/\Qcalled at accessor Foo::baz of attribute bar (defined at $0 line $attr_bar_line)\E/, + "got definition context for the accessor" + ); +} + +{ + my ($dtor_line); + { + package Bar; + use Moose; + + # just dying here won't work, because perl's exception handling is + # terrible + sub DEMOLISH { try { confess } catch { warn $_ } } + + __PACKAGE__->meta->make_immutable; + $dtor_line = __LINE__ - 1; + } + + { + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= $_[0] }; + { Bar->new } + like( + $warning, + qr/\Qcalled at destructor Bar::DESTROY (defined at $0 line $dtor_line)\E/, + "got definition context for the destructor" + ); + } +} + +done_testing; diff --git a/t/immutable/immutable_constructor_error.t b/t/immutable/immutable_constructor_error.t new file mode 100644 index 0000000..cb22171 --- /dev/null +++ b/t/immutable/immutable_constructor_error.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This tests to make sure that we provide the same error messages from +an immutable constructor as is provided by a non-immutable +constructor. + +=cut + +{ + package Foo; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Int'); + + Foo->meta->make_immutable(debug => 0); +} + +my $scalar = 1; +like( exception { Foo->new($scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Non-ref provided to immutable constructor gives useful error message' ); +like( exception { Foo->new(\$scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Scalar ref provided to immutable constructor gives useful error message' ); +like( exception { Foo->new(undef) }, qr/\QSingle parameters to new() must be a HASH ref/, 'undef provided to immutable constructor gives useful error message' ); + +done_testing; diff --git a/t/immutable/immutable_destroy.t b/t/immutable/immutable_destroy.t new file mode 100644 index 0000000..8dfc3d3 --- /dev/null +++ b/t/immutable/immutable_destroy.t @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More; + +{ + package FooBar; + use Moose; + + has 'name' => ( is => 'ro' ); + + sub DESTROY { shift->name } + + local $SIG{__WARN__} = sub {}; + __PACKAGE__->meta->make_immutable; +} + +my $f = FooBar->new( name => 'SUSAN' ); + +is( $f->DESTROY, 'SUSAN', 'Did moose overload DESTROY?' ); + +done_testing; diff --git a/t/immutable/immutable_meta_class.t b/t/immutable/immutable_meta_class.t new file mode 100644 index 0000000..3c52d92 --- /dev/null +++ b/t/immutable/immutable_meta_class.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Meta; + + use Moose; + + extends 'Moose::Meta::Class'; + + has 'meta_size' => ( + is => 'rw', + isa => 'Int', + ); +} + +is( exception { + My::Meta->meta()->make_immutable(debug => 0) +}, undef, '... can make a meta class immutable' ); + +done_testing; diff --git a/t/immutable/immutable_metaclass_with_traits.t b/t/immutable/immutable_metaclass_with_traits.t new file mode 100644 index 0000000..466a7c0 --- /dev/null +++ b/t/immutable/immutable_metaclass_with_traits.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More; + +{ + package FooTrait; + use Moose::Role; +} +{ + package Foo; + use Moose -traits => ['FooTrait']; +} + +is(Class::MOP::class_of('Foo'), Foo->meta, + "class_of and ->meta are the same on Foo"); +my $meta = Foo->meta; +is(Class::MOP::class_of($meta), $meta->meta, + "class_of and ->meta are the same on Foo's metaclass"); +isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class'); +isa_ok($meta->meta, 'Moose::Meta::Class'); +ok($meta->is_mutable, "class is mutable"); +ok(Class::MOP::class_of($meta)->is_mutable, "metaclass is mutable"); +ok($meta->meta->does_role('FooTrait'), "does the trait"); +Foo->meta->make_immutable; +is(Class::MOP::class_of('Foo'), Foo->meta, + "class_of and ->meta are the same on Foo (immutable)"); +$meta = Foo->meta; +isa_ok($meta->meta, 'Moose::Meta::Class'); +ok($meta->is_immutable, "class is immutable"); +ok($meta->meta->is_immutable, "metaclass is immutable (immutable class)"); +is(Class::MOP::class_of($meta), $meta->meta, + "class_of and ->meta are the same on Foo's metaclass (immutable)"); +isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class'); +ok($meta->meta->does_role('FooTrait'), "still does the trait after immutable"); + +done_testing; diff --git a/t/immutable/immutable_moose.t b/t/immutable/immutable_moose.t new file mode 100644 index 0000000..d77ea37 --- /dev/null +++ b/t/immutable/immutable_moose.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role; + + +{ + package FooRole; + our $VERSION = '0.01'; + sub foo {'FooRole::foo'} +} + +{ + package Foo; + use Moose; + + #two checks because the inlined methods are different when + #there is a TC present. + has 'foos' => ( is => 'ro', lazy_build => 1 ); + has 'bars' => ( isa => 'Str', is => 'ro', lazy_build => 1 ); + has 'bazes' => ( isa => 'Str', is => 'ro', builder => '_build_bazes' ); + sub _build_foos {"many foos"} + sub _build_bars {"many bars"} + sub _build_bazes {"many bazes"} +} + +{ + my $foo_role = Moose::Meta::Role->initialize('FooRole'); + my $meta = Foo->meta; + + is( exception { Foo->new }, undef, "lazy_build works" ); + is( Foo->new->foos, 'many foos', + "correct value for 'foos' before inlining constructor" ); + is( Foo->new->bars, 'many bars', + "correct value for 'bars' before inlining constructor" ); + is( Foo->new->bazes, 'many bazes', + "correct value for 'bazes' before inlining constructor" ); + is( exception { $meta->make_immutable }, undef, "Foo is imutable" ); + is( exception { $meta->identifier }, undef, "->identifier on metaclass lives" ); + isnt( exception { $meta->add_role($foo_role) }, undef, "Add Role is locked" ); + is( exception { Foo->new }, undef, "Inlined constructor works with lazy_build" ); + is( Foo->new->foos, 'many foos', + "correct value for 'foos' after inlining constructor" ); + is( Foo->new->bars, 'many bars', + "correct value for 'bars' after inlining constructor" ); + is( Foo->new->bazes, 'many bazes', + "correct value for 'bazes' after inlining constructor" ); + is( exception { $meta->make_mutable }, undef, "Foo is mutable" ); + is( exception { $meta->add_role($foo_role) }, undef, "Add Role is unlocked" ); + +} + +{ + package Bar; + + use Moose; + + sub BUILD { 'bar' } +} + +{ + package Baz; + + use Moose; + + extends 'Bar'; + + sub BUILD { 'baz' } +} + +is( exception { Bar->meta->make_immutable }, undef, 'Immutable meta with single BUILD' ); + +is( exception { Baz->meta->make_immutable }, undef, 'Immutable meta with multiple BUILDs' ); + +=pod + +Nothing here yet, but soon :) + +=cut + +done_testing; diff --git a/t/immutable/immutable_roundtrip.t b/t/immutable/immutable_roundtrip.t new file mode 100644 index 0000000..2f1bceb --- /dev/null +++ b/t/immutable/immutable_roundtrip.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + __PACKAGE__->meta->make_immutable; + __PACKAGE__->meta->make_mutable; + + + # This actually is testing for a bug in Class::MOP that cause + # Moose::Meta::Method::Constructor to spit out a warning when it + # shouldn't have done so. The bug was fixed in CMOP 0.75. + ::stderr_unlike( + sub { Bar->meta->make_immutable }, + qr/Not inlining a constructor/, + 'no warning that Bar may not have an inlined constructor' + ); +} + +done_testing; diff --git a/t/immutable/immutable_trigger_from_constructor.t b/t/immutable/immutable_trigger_from_constructor.t new file mode 100644 index 0000000..799cecc --- /dev/null +++ b/t/immutable/immutable_trigger_from_constructor.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package AClass; + + use Moose; + + has 'foo' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { + die "Pulling the Foo trigger\n" + }); + + has 'bar' => (is => 'rw', isa => 'Maybe[Str]'); + + has 'baz' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { + die "Pulling the Baz trigger\n" + }); + + __PACKAGE__->meta->make_immutable; #(debug => 1); + + no Moose; +} + +eval { AClass->new(foo => 'bar') }; +like ($@, qr/^Pulling the Foo trigger/, "trigger from immutable constructor"); + +eval { AClass->new(baz => 'bar') }; +like ($@, qr/^Pulling the Baz trigger/, "trigger from immutable constructor"); + +is( exception { AClass->new(bar => 'bar') }, undef, '... no triggers called' ); + +done_testing; diff --git a/t/immutable/inline_close_over.t b/t/immutable/inline_close_over.t new file mode 100644 index 0000000..3b01504 --- /dev/null +++ b/t/immutable/inline_close_over.t @@ -0,0 +1,361 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires qw(Data::Visitor PadWalker); + +use Class::Load 'load_class'; +use Try::Tiny; + +my $can_partialdump = try { + load_class('Devel::PartialDump', { -version => 0.14 }); 1; +}; + +{ + package Test::Visitor; + use Moose; + use Moose::Util::TypeConstraints; + extends 'Data::Visitor'; + + has closed_over => ( + traits => ['Array'], + isa => 'ArrayRef', + default => sub { [] }, + handles => { + add_closed_over => 'push', + closed_over => 'elements', + pass => 'is_empty', + }, + ); + + before visit_code => sub { + my $self = shift; + my ($code) = @_; + my $closed_over = PadWalker::closed_over($code); + $self->visit_ref($closed_over); + }; + + after visit => sub { + my $self = shift; + my ($thing) = @_; + + $self->add_closed_over($thing) + unless $self->_is_okay_to_close_over($thing); + }; + + sub _is_okay_to_close_over { + my $self = shift; + my ($thing) = @_; + + match_on_type $thing => ( + 'RegexpRef' => sub { 1 }, + 'Object' => sub { 0 }, + 'GlobRef' => sub { 0 }, + 'FileHandle' => sub { 0 }, + 'Any' => sub { 1 }, + ); + } +} + +sub close_over_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($package, $method) = @_; + my $visitor = Test::Visitor->new; + my $code = $package->meta->find_method_by_name($method)->body; + $visitor->visit($code); + if ($visitor->pass) { + pass("${package}::${method} didn't close over anything complicated"); + } + else { + fail("${package}::${method} closed over some stuff:"); + my @closed_over = $visitor->closed_over; + for my $i (1..10) { + last unless @closed_over; + my $closed_over = shift @closed_over; + if ($can_partialdump) { + $closed_over = Devel::PartialDump->new->dump($closed_over); + } + diag($closed_over); + } + diag("... and " . scalar(@closed_over) . " more") + if @closed_over; + } +} + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has foo => ( + is => 'ro', + isa => 'Str', + ); + + has bar => ( + is => 'ro', + isa => 'Int', + default => 1, + ); + + has baz => ( + is => 'rw', + isa => 'ArrayRef[Num]', + default => sub { [ 1.2 ] }, + trigger => sub { warn "blah" }, + ); + + subtype 'Thing', + as 'Int', + where { $_ < 5 }, + message { "must be less than 5" }; + has quux => ( + is => 'rw', + isa => 'Thing', + predicate => 'has_quux', + clearer => 'clear_quux', + ); + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux); + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; + + around foo => sub { + my $orig = shift; + my $self = shift; + $self->$orig(@_); + }; + + after bar => sub { }; + before baz => sub { }; + override quux => sub { super }; + + sub blah { inner } + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah); + +{ + package Foo::Sub::Sub; + use Moose; + extends 'Foo::Sub'; + + augment blah => { inner }; + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('Foo::Sub::Sub', $_) for qw(new blah); + +{ + my %handles = ( + Array => { + count => 'count', + elements => 'elements', + is_empty => 'is_empty', + push => 'push', + push_curried => [ push => 42, 84 ], + unshift => 'unshift', + unshift_curried => [ unshift => 42, 84 ], + pop => 'pop', + shift => 'shift', + get => 'get', + get_curried => [ get => 1 ], + set => 'set', + set_curried_1 => [ set => 1 ], + set_curried_2 => [ set => ( 1, 98 ) ], + accessor => 'accessor', + accessor_curried_1 => [ accessor => 1 ], + accessor_curried_2 => [ accessor => ( 1, 90 ) ], + clear => 'clear', + delete => 'delete', + delete_curried => [ delete => 1 ], + insert => 'insert', + insert_curried => [ insert => ( 1, 101 ) ], + splice => 'splice', + splice_curried_1 => [ splice => 1 ], + splice_curried_2 => [ splice => 1, 2 ], + splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + sort => 'sort', + sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], + sort_in_place => 'sort_in_place', + sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + map => 'map', + map_curried => [ map => ( sub { $_ + 1 } ) ], + grep => 'grep', + grep_curried => [ grep => ( sub { $_ < 5 } ) ], + first => 'first', + first_curried => [ first => ( sub { $_ % 2 } ) ], + join => 'join', + join_curried => [ join => '-' ], + shuffle => 'shuffle', + uniq => 'uniq', + reduce => 'reduce', + reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], + natatime => 'natatime', + natatime_curried => [ natatime => 2 ], + }, + Hash => { + option_accessor => 'accessor', + quantity => [ accessor => 'quantity' ], + clear_options => 'clear', + num_options => 'count', + delete_option => 'delete', + is_defined => 'defined', + options_elements => 'elements', + has_option => 'exists', + get_option => 'get', + has_no_options => 'is_empty', + keys => 'keys', + values => 'values', + key_value => 'kv', + set_option => 'set', + }, + Counter => { + inc_counter => 'inc', + inc_counter_2 => [ inc => 2 ], + dec_counter => 'dec', + dec_counter_2 => [ dec => 2 ], + reset_counter => 'reset', + set_counter => 'set', + set_counter_42 => [ set => 42 ], + }, + Number => { + abs => 'abs', + add => 'add', + inc => [ add => 1 ], + div => 'div', + cut_in_half => [ div => 2 ], + mod => 'mod', + odd => [ mod => 2 ], + mul => 'mul', + set => 'set', + sub => 'sub', + dec => [ sub => 1 ], + }, + Bool => { + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + }, + String => { + inc => 'inc', + append => 'append', + append_curried => [ append => '!' ], + prepend => 'prepend', + prepend_curried => [ prepend => '-' ], + replace => 'replace', + replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], + chop => 'chop', + chomp => 'chomp', + clear => 'clear', + match => 'match', + match_curried => [ match => qr/\D/ ], + length => 'length', + substr => 'substr', + substr_curried_1 => [ substr => (1) ], + substr_curried_2 => [ substr => ( 1, 3 ) ], + substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], + }, + Code => { + execute => 'execute', + execute_method => 'execute_method', + }, + ); + + my %isa = ( + Array => 'ArrayRef[Str]', + Hash => 'HashRef[Int]', + Counter => 'Int', + Number => 'Num', + Bool => 'Bool', + String => 'Str', + Code => 'CodeRef', + ); + + my %default = ( + Array => [], + Hash => {}, + Counter => 0, + Number => 0.0, + Bool => 1, + String => '', + Code => sub { }, + ); + + for my $trait (keys %default) { + my $class_name = "Native::$trait"; + my $handles = $handles{$trait}; + my $attr_class = Moose::Util::with_traits( + 'Moose::Meta::Attribute', + "Moose::Meta::Attribute::Native::Trait::$trait", + ); + Moose::Meta::Class->create( + $class_name, + superclasses => ['Moose::Object'], + attributes => [ + $attr_class->new( + 'nonlazy', + is => 'ro', + isa => $isa{$trait}, + default => sub { $default{$trait} }, + handles => { + map {; "nonlazy_$_" => $handles->{$_} } keys %$handles + }, + ), + $attr_class->new( + 'lazy', + is => 'ro', + isa => $isa{$trait}, + lazy => 1, + default => sub { $default{$trait} }, + handles => { + map {; "lazy_$_" => $handles->{$_} } keys %$handles + }, + ), + ], + ); + close_over_ok($class_name, $_) for ( + 'new', + map {; "nonlazy_$_", "lazy_$_" } keys %$handles + ); + } +} + +{ + package WithInitializer; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Str', + initializer => sub { }, + ); + + has bar => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { 'a' }, + initializer => sub { }, + ); + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('WithInitializer', 'foo'); +{ local $TODO = "initializer still closes over things"; +close_over_ok('WithInitializer', $_) for qw(new bar); +} + +done_testing; diff --git a/t/immutable/inline_fallbacks.t b/t/immutable/inline_fallbacks.t new file mode 100644 index 0000000..362d60e --- /dev/null +++ b/t/immutable/inline_fallbacks.t @@ -0,0 +1,70 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + has foo => (is => 'ro'); +} + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; + has bar => (is => 'ro'); +} + +{ + my $foo = Foo::Sub->new(foo => 12, bar => 25); + is($foo->foo, 12, 'got right value for foo'); + is($foo->bar, 25, 'got right value for bar'); +} + +Foo->meta->make_immutable; + +{ + package Foo::Sub2; + use Moose; + extends 'Foo'; + has baz => (is => 'ro'); + # not making immutable, inheriting Foo's inlined constructor +} + +{ + my $foo = Foo::Sub2->new(foo => 42, baz => 27); + is($foo->foo, 42, 'got right value for foo'); + is($foo->baz, 27, 'got right value for baz'); +} + +my $BAR = 0; +{ + package Bar; + use Moose; +} + +{ + package Bar::Sub; + use Moose; + extends 'Bar'; + sub DEMOLISH { $BAR++ } +} + +Bar::Sub->new; +is($BAR, 1, 'DEMOLISH in subclass was called'); +$BAR = 0; + +Bar->meta->make_immutable; + +{ + package Bar::Sub2; + use Moose; + extends 'Bar'; + sub DEMOLISH { $BAR++ } + # not making immutable, inheriting Bar's inlined destructor +} + +Bar::Sub2->new; +is($BAR, 1, 'DEMOLISH in subclass was called'); + +done_testing; diff --git a/t/immutable/inlined_constructors_n_types.t b/t/immutable/inlined_constructors_n_types.t new file mode 100644 index 0000000..3df1fb0 --- /dev/null +++ b/t/immutable/inlined_constructors_n_types.t @@ -0,0 +1,60 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +This tests to make sure that the inlined constructor +has all the type constraints in order, even in the +cases when there is no type constraint available, such +as with a Class::MOP::Attribute object. + +=cut + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 }; + + has 'foo' => (is => 'rw', isa => 'Int'); + has 'baz' => (is => 'rw', isa => 'Int'); + has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef); + has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1); + has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1); + + sub _build_boo { '' } + + Foo->meta->add_attribute( + Class::MOP::Attribute->new( + 'bar' => ( + accessor => 'bar', + ) + ) + ); +} + +for (1..2) { + my $is_immutable = Foo->meta->is_immutable; + my $mutable_string = $is_immutable ? 'immutable' : 'mutable'; + is( exception { + my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4); + is($f->moo, 69, "Type coercion works as expected on default ($mutable_string)"); + is($f->boo, 69, "Type coercion works as expected on builder ($mutable_string)"); + }, undef, "... this passes the constuctor correctly ($mutable_string)" ); + + is( exception { + Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int"); + }, undef, "... the constructor doesn't care about 'zot' ($mutable_string)" ); + + isnt( exception { + Foo->new(foo => "Hello World", bar => 100, baz => "Hello World"); + }, undef, "... this fails the constuctor correctly ($mutable_string)" ); + + Foo->meta->make_immutable(debug => 0) unless $is_immutable; +} + +done_testing; diff --git a/t/immutable/multiple_demolish_inline.t b/t/immutable/multiple_demolish_inline.t new file mode 100644 index 0000000..e9727ac --- /dev/null +++ b/t/immutable/multiple_demolish_inline.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Int'); + + sub DEMOLISH { } +} + +{ + package Bar; + use Moose; + + extends qw(Foo); + has 'bar' => (is => 'rw', isa => 'Int'); + + sub DEMOLISH { } +} + +is( exception { + Bar->new(); +}, undef, 'Bar->new()' ); + +is( exception { + Bar->meta->make_immutable; +}, undef, 'Bar->meta->make_immutable' ); + +is( Bar->meta->get_method('DESTROY')->package_name, 'Bar', + 'Bar has a DESTROY method in the Bar class (not inherited)' ); + +is( exception { + Foo->meta->make_immutable; +}, undef, 'Foo->meta->make_immutable' ); + +is( Foo->meta->get_method('DESTROY')->package_name, 'Foo', + 'Foo has a DESTROY method in the Bar class (not inherited)' ); + +done_testing; diff --git a/t/lib/Bar.pm b/t/lib/Bar.pm new file mode 100644 index 0000000..b520c7a --- /dev/null +++ b/t/lib/Bar.pm @@ -0,0 +1,9 @@ +package Bar; +use Moose; +use Moose::Util::TypeConstraints; + +type Baz => where { 1 }; + +subtype Bling => as Baz => where { 1 }; + +1;
\ No newline at end of file diff --git a/t/lib/Bar7/Meta/Trait.pm b/t/lib/Bar7/Meta/Trait.pm new file mode 100644 index 0000000..aec769b --- /dev/null +++ b/t/lib/Bar7/Meta/Trait.pm @@ -0,0 +1,8 @@ +package Bar7::Meta::Trait; +use Moose::Role; + +around _immutable_options => sub { }; + +no Moose::Role; + +1; diff --git a/t/lib/Bar7/Meta/Trait2.pm b/t/lib/Bar7/Meta/Trait2.pm new file mode 100644 index 0000000..4f1b73f --- /dev/null +++ b/t/lib/Bar7/Meta/Trait2.pm @@ -0,0 +1,13 @@ +package Bar7::Meta::Trait2; +use Moose::Role; + +has foo => ( + traits => ['Array'], + handles => { + push_foo => 'push', + }, +); + +no Moose::Role; + +1; diff --git a/t/lib/Foo.pm b/t/lib/Foo.pm new file mode 100644 index 0000000..048870c --- /dev/null +++ b/t/lib/Foo.pm @@ -0,0 +1,6 @@ +package Foo; +use Moose; + +has 'bar' => (is => 'rw'); + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Bar.pm b/t/lib/Moose/Meta/Attribute/Custom/Bar.pm new file mode 100644 index 0000000..64dd230 --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Bar.pm @@ -0,0 +1,10 @@ +package Moose::Meta::Attribute::Custom::Bar; + +sub register_implementation { 'My::Bar' } + + +package My::Bar; + +use Moose::Role; + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Foo.pm b/t/lib/Moose/Meta/Attribute/Custom/Foo.pm new file mode 100644 index 0000000..49f7a01 --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Foo.pm @@ -0,0 +1,5 @@ +package Moose::Meta::Attribute::Custom::Foo; + +use Moose::Role; + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm b/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm new file mode 100644 index 0000000..17412c1 --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm @@ -0,0 +1,10 @@ +package Moose::Meta::Attribute::Custom::Trait::Bar; + +sub register_implementation { 'My::Trait::Bar' } + + +package My::Trait::Bar; + +use Moose::Role; + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm b/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm new file mode 100644 index 0000000..682b61f --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm @@ -0,0 +1,5 @@ +package Moose::Meta::Attribute::Custom::Trait::Foo; + +use Moose::Role; + +1; diff --git a/t/lib/MyExporter.pm b/t/lib/MyExporter.pm new file mode 100644 index 0000000..bda6f20 --- /dev/null +++ b/t/lib/MyExporter.pm @@ -0,0 +1,22 @@ +package MyExporter; +use Moose::Exporter; +use Test::More; + +Moose::Exporter->setup_import_methods( + with_meta => [qw(with_prototype)], + as_is => [qw(as_is_prototype)], +); + +sub with_prototype (&) { + my ($class, $code) = @_; + isa_ok($code, 'CODE', 'with_prototype received a coderef'); + $code->(); +} + +sub as_is_prototype (&) { + my ($code) = @_; + isa_ok($code, 'CODE', 'as_is_prototype received a coderef'); + $code->(); +} + +1; diff --git a/t/lib/MyMetaclassRole.pm b/t/lib/MyMetaclassRole.pm new file mode 100644 index 0000000..362265a --- /dev/null +++ b/t/lib/MyMetaclassRole.pm @@ -0,0 +1,4 @@ +package MyMetaclassRole; +use Moose::Role; + +1; diff --git a/t/lib/MyMooseA.pm b/t/lib/MyMooseA.pm new file mode 100644 index 0000000..9e520b9 --- /dev/null +++ b/t/lib/MyMooseA.pm @@ -0,0 +1,7 @@ +package MyMooseA; + +use Moose; + +has 'b' => (is => 'rw', isa => 'MyMooseB'); + +1;
\ No newline at end of file diff --git a/t/lib/MyMooseB.pm b/t/lib/MyMooseB.pm new file mode 100644 index 0000000..c772947 --- /dev/null +++ b/t/lib/MyMooseB.pm @@ -0,0 +1,5 @@ +package MyMooseB; + +use Moose; + +1;
\ No newline at end of file diff --git a/t/lib/MyMooseObject.pm b/t/lib/MyMooseObject.pm new file mode 100644 index 0000000..5f1a6f7 --- /dev/null +++ b/t/lib/MyMooseObject.pm @@ -0,0 +1,7 @@ +package MyMooseObject; + +use strict; +use warnings; +use parent 'Moose::Object'; + +1; diff --git a/t/lib/NoInlineAttribute.pm b/t/lib/NoInlineAttribute.pm new file mode 100644 index 0000000..af182dc --- /dev/null +++ b/t/lib/NoInlineAttribute.pm @@ -0,0 +1,29 @@ +package NoInlineAttribute; + +use Moose::Meta::Class; +use Moose::Role; + +around accessor_metaclass => sub { + my $orig = shift; + my $self = shift; + + my $class = $self->$orig(); + + return Moose::Meta::Class->create_anon_class( + superclasses => [$class], + roles => ['NoInlineAccessor'], + cache => 1, + )->name; +}; + +no Moose::Role; + +{ + package NoInlineAccessor; + + use Moose::Role; + + sub is_inline { 0 } +} + +1; diff --git a/t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm b/t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm new file mode 100644 index 0000000..2cfe5e1 --- /dev/null +++ b/t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm @@ -0,0 +1,7 @@ +package Overloading::ClassConsumesRoleConsumesOverloads; + +use Moose; + +with 'Overloading::RoleConsumesOverloads'; + +1; diff --git a/t/lib/Overloading/ClassWithCombiningRole.pm b/t/lib/Overloading/ClassWithCombiningRole.pm new file mode 100644 index 0000000..5e953f5 --- /dev/null +++ b/t/lib/Overloading/ClassWithCombiningRole.pm @@ -0,0 +1,7 @@ +package Overloading::ClassWithCombiningRole; + +use Moose; + +with 'Overloading::CombiningRole'; + +1; diff --git a/t/lib/Overloading/ClassWithOneRole.pm b/t/lib/Overloading/ClassWithOneRole.pm new file mode 100644 index 0000000..89d135a --- /dev/null +++ b/t/lib/Overloading/ClassWithOneRole.pm @@ -0,0 +1,7 @@ +package Overloading::ClassWithOneRole; + +use Moose; + +with 'Overloading::RoleWithOverloads'; + +1; diff --git a/t/lib/Overloading/CombiningClass.pm b/t/lib/Overloading/CombiningClass.pm new file mode 100644 index 0000000..524ef46 --- /dev/null +++ b/t/lib/Overloading/CombiningClass.pm @@ -0,0 +1,7 @@ +package Overloading::CombiningClass; + +use Moose; + +with 'Overloading::RoleWithOverloads', 'Overloading::RoleWithoutOverloads'; + +1; diff --git a/t/lib/Overloading/CombiningRole.pm b/t/lib/Overloading/CombiningRole.pm new file mode 100644 index 0000000..db523cb --- /dev/null +++ b/t/lib/Overloading/CombiningRole.pm @@ -0,0 +1,7 @@ +package Overloading::CombiningRole; + +use Moose::Role; + +with 'Overloading::RoleWithOverloads', 'Overloading::RoleWithoutOverloads'; + +1; diff --git a/t/lib/Overloading/RoleConsumesOverloads.pm b/t/lib/Overloading/RoleConsumesOverloads.pm new file mode 100644 index 0000000..0e0e476 --- /dev/null +++ b/t/lib/Overloading/RoleConsumesOverloads.pm @@ -0,0 +1,7 @@ +package Overloading::RoleConsumesOverloads; + +use Moose::Role; + +with 'Overloading::RoleWithOverloads'; + +1; diff --git a/t/lib/Overloading/RoleWithOverloads.pm b/t/lib/Overloading/RoleWithOverloads.pm new file mode 100644 index 0000000..31471cf --- /dev/null +++ b/t/lib/Overloading/RoleWithOverloads.pm @@ -0,0 +1,16 @@ +package Overloading::RoleWithOverloads; + +use Moose::Role; + +use overload + q{""} => 'as_string', + fallback => 1; + +has message => ( + is => 'rw', + isa => 'Str', +); + +sub as_string { shift->message } + +1; diff --git a/t/lib/Overloading/RoleWithoutOverloads.pm b/t/lib/Overloading/RoleWithoutOverloads.pm new file mode 100644 index 0000000..97d3e80 --- /dev/null +++ b/t/lib/Overloading/RoleWithoutOverloads.pm @@ -0,0 +1,5 @@ +package Overloading::RoleWithoutOverloads; + +use Moose::Role; + +1; diff --git a/t/lib/OverloadingTests.pm b/t/lib/OverloadingTests.pm new file mode 100644 index 0000000..d1ab195 --- /dev/null +++ b/t/lib/OverloadingTests.pm @@ -0,0 +1,47 @@ +package OverloadingTests; + +use strict; +use warnings; + +use Test::More 0.88; + +sub test_overloading_for_package { + my $package = shift; + + ok( + overload::Overloaded($package), + "$package is overloaded" + ); + ok( + overload::Method( $package, q{""} ), + "$package overloads stringification" + ); +} + +sub test_no_overloading_for_package { + my $package = shift; + + ok( + !overload::Overloaded($package), + "$package is not overloaded" + ); + ok( + !overload::Method( $package, q{""} ), + "$package does not overload stringification" + ); +} + +sub test_overloading_for_object { + my $class = shift; + my $thing = shift || "$class object"; + + my $object = ref $class ? $class : $class->new( { message => 'foo' } ); + + is( + "$object", + 'foo', + "$thing stringifies to value of message attribute" + ); +} + +1; diff --git a/t/lib/Real/Package.pm b/t/lib/Real/Package.pm new file mode 100644 index 0000000..98b3d47 --- /dev/null +++ b/t/lib/Real/Package.pm @@ -0,0 +1,7 @@ +package Real::Package; +use strict; +use warnings; + +sub foo { } + +1; diff --git a/t/lib/Role/BreakOnLoad.pm b/t/lib/Role/BreakOnLoad.pm new file mode 100644 index 0000000..48367a7 --- /dev/null +++ b/t/lib/Role/BreakOnLoad.pm @@ -0,0 +1,8 @@ +package Role::BreakOnLoad; +use Moose::Role; + +sub meth1 { } + +this role has a syntax error and should crash on load. + +1; diff --git a/t/lib/Role/Child.pm b/t/lib/Role/Child.pm new file mode 100644 index 0000000..4c70436 --- /dev/null +++ b/t/lib/Role/Child.pm @@ -0,0 +1,8 @@ +package Role::Child; +use Moose::Role; + +with 'Role::Parent' => { -alias => { meth1 => 'aliased_meth1', } }; + +sub meth1 { } + +1; diff --git a/t/lib/Role/Interface.pm b/t/lib/Role/Interface.pm new file mode 100644 index 0000000..025cf40 --- /dev/null +++ b/t/lib/Role/Interface.pm @@ -0,0 +1,6 @@ +package Role::Interface; +use Moose::Role; + +requires "meth2"; + +1; diff --git a/t/lib/Role/Parent.pm b/t/lib/Role/Parent.pm new file mode 100644 index 0000000..0f49427 --- /dev/null +++ b/t/lib/Role/Parent.pm @@ -0,0 +1,7 @@ +package Role::Parent; +use Moose::Role; + +sub meth2 { } +sub meth1 { } + +1; diff --git a/t/metaclasses/create_anon_with_required_attr.t b/t/metaclasses/create_anon_with_required_attr.t new file mode 100644 index 0000000..3a37773 --- /dev/null +++ b/t/metaclasses/create_anon_with_required_attr.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + +# this functionality may be pushing toward parametric roles/classes +# it's off in a corner and may not be that important + +use Test::More; +use Test::Fatal; + +{ + package HasFoo; + use Moose::Role; + has 'foo' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + +} + +{ + package My::Metaclass; + use Moose; + extends 'Moose::Meta::Class'; + with 'HasFoo'; +} + +package main; + +my $anon; +is( exception { + $anon = My::Metaclass->create_anon_class( foo => 'this' ); +}, undef, 'create anon class with required attr' ); +isa_ok( $anon, 'My::Metaclass' ); +cmp_ok( $anon->foo, 'eq', 'this', 'foo is this' ); +isnt( exception { + $anon = My::Metaclass->create_anon_class(); +}, undef, 'failed to create anon class without required attr' ); + +my $meta; +is( exception { + $meta + = My::Metaclass->initialize( 'Class::Name1' => ( foo => 'that' ) ); +}, undef, 'initialize a class with required attr' ); +isa_ok( $meta, 'My::Metaclass' ); +cmp_ok( $meta->foo, 'eq', 'that', 'foo is that' ); +cmp_ok( $meta->name, 'eq', 'Class::Name1', 'for the correct class' ); +isnt( exception { + $meta + = My::Metaclass->initialize( 'Class::Name2' ); +}, undef, 'failed to initialize a class without required attr' ); + +is( exception { + eval qq{ + package Class::Name3; + use metaclass 'My::Metaclass' => ( + foo => 'another', + ); + use Moose; + }; + die $@ if $@; +}, undef, 'use metaclass with required attr' ); +$meta = Class::Name3->meta; +isa_ok( $meta, 'My::Metaclass' ); +cmp_ok( $meta->foo, 'eq', 'another', 'foo is another' ); +cmp_ok( $meta->name, 'eq', 'Class::Name3', 'for the correct class' ); +isnt( exception { + eval qq{ + package Class::Name4; + use metaclass 'My::Metaclass'; + use Moose; + }; + die $@ if $@; +}, undef, 'failed to use metaclass without required attr' ); + + +# how do we pass a required attribute to -traits? +isnt( exception { + eval qq{ + package Class::Name5; + use Moose -traits => 'HasFoo'; + }; + die $@ if $@; +}, undef, 'failed to use trait without required attr' ); + +done_testing; diff --git a/t/metaclasses/custom_attr_meta_as_role.t b/t/metaclasses/custom_attr_meta_as_role.t new file mode 100644 index 0000000..d1790d4 --- /dev/null +++ b/t/metaclasses/custom_attr_meta_as_role.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +is( exception { + package MooseX::Attribute::Test; + use Moose::Role; +}, undef, 'creating custom attribute "metarole" is okay' ); + +is( exception { + package Moose::Meta::Attribute::Custom::Test; + use Moose; + + extends 'Moose::Meta::Attribute'; + with 'MooseX::Attribute::Test'; +}, undef, 'custom attribute metaclass extending role is okay' ); + +done_testing; diff --git a/t/metaclasses/custom_attr_meta_with_roles.t b/t/metaclasses/custom_attr_meta_with_roles.t new file mode 100644 index 0000000..d6d43bc --- /dev/null +++ b/t/metaclasses/custom_attr_meta_with_roles.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package My::Custom::Meta::Attr; + use Moose; + + extends 'Moose::Meta::Attribute'; +} + +{ + package My::Fancy::Role; + use Moose::Role; + + has 'bling_bling' => ( + metaclass => 'My::Custom::Meta::Attr', + is => 'rw', + isa => 'Str', + ); +} + +{ + package My::Class; + use Moose; + + with 'My::Fancy::Role'; +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +ok($c->meta->has_attribute('bling_bling'), '... got the attribute'); + +isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr'); + +done_testing; diff --git a/t/metaclasses/easy_init_meta.t b/t/metaclasses/easy_init_meta.t new file mode 100644 index 0000000..b199b6a --- /dev/null +++ b/t/metaclasses/easy_init_meta.t @@ -0,0 +1,126 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose qw(does_ok); + +{ + package Foo::Trait::Class; + use Moose::Role; +} + +{ + package Foo::Trait::Attribute; + use Moose::Role; +} + +{ + package Foo::Role::Base; + use Moose::Role; +} + +{ + package Foo::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + role_metaroles => { role => ['Foo::Trait::Class'] }, + base_class_roles => ['Foo::Role::Base'], + ); +} + +{ + package Foo; + use Moose; + Foo::Exporter->import; + + has foo => (is => 'ro'); + + ::does_ok(Foo->meta, 'Foo::Trait::Class'); + ::does_ok(Foo->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); + ::does_ok('Foo', 'Foo::Role::Base'); +} + +{ + package Foo::Exporter::WithMoose; + use Moose (); + use Moose::Exporter; + + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods( + also => 'Moose', + class_metaroles => { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + base_class_roles => ['Foo::Role::Base'], + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2; + Foo::Exporter::WithMoose->import; + + has(foo => (is => 'ro')); + + ::isa_ok('Foo2', 'Moose::Object'); + ::isa_ok(Foo2->meta, 'Moose::Meta::Class'); + ::does_ok(Foo2->meta, 'Foo::Trait::Class'); + ::does_ok(Foo2->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); + ::does_ok('Foo2', 'Foo::Role::Base'); +} + +{ + package Foo::Role; + use Moose::Role; + Foo::Exporter->import; + + ::does_ok(Foo::Role->meta, 'Foo::Trait::Class'); +} + +{ + package Foo::Exporter::WithMooseRole; + use Moose::Role (); + use Moose::Exporter; + + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods( + also => 'Moose::Role', + role_metaroles => { + role => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose::Role->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2::Role; + Foo::Exporter::WithMooseRole->import; + + ::isa_ok(Foo2::Role->meta, 'Moose::Meta::Role'); + ::does_ok(Foo2::Role->meta, 'Foo::Trait::Class'); +} + +done_testing; diff --git a/t/metaclasses/export_with_prototype.t b/t/metaclasses/export_with_prototype.t new file mode 100644 index 0000000..97227c6 --- /dev/null +++ b/t/metaclasses/export_with_prototype.t @@ -0,0 +1,22 @@ +use lib "t/lib"; +package MyExporter::User; +use MyExporter; + +use Test::More; +use Test::Fatal; + +is( exception { + with_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "With_caller prototype code gets called from MyMooseX"); + }; +}, undef, "check function with prototype" ); + +is( exception { + as_is_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "As-is prototype code gets called from MyMooseX"); + }; +}, undef, "check function with prototype" ); + +done_testing; diff --git a/t/metaclasses/exporter_also_with_trait.t b/t/metaclasses/exporter_also_with_trait.t new file mode 100644 index 0000000..ca79ceb --- /dev/null +++ b/t/metaclasses/exporter_also_with_trait.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +BEGIN { + package My::Meta::Role; + use Moose::Role; +} + +BEGIN { + package My::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + class_metaroles => { + class => ['My::Meta::Role'], + }, + ); + $INC{'My/Exporter.pm'} = __FILE__; +} + +{ + package My::Class; + use My::Exporter; +} + +{ + my $meta = My::Class->meta; + isa_ok($meta, 'Moose::Meta::Class'); + does_ok($meta, 'My::Meta::Role'); +} + +done_testing; diff --git a/t/metaclasses/exporter_meta_lookup.t b/t/metaclasses/exporter_meta_lookup.t new file mode 100644 index 0000000..629b48b --- /dev/null +++ b/t/metaclasses/exporter_meta_lookup.t @@ -0,0 +1,62 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Class::Vacuum::Innards; + use Moose; + + package Class::Vacuum; + use Moose (); + use Moose::Exporter; + + sub meta_lookup { $_[0] } + + BEGIN { + Moose::Exporter->setup_import_methods( + also => 'Moose', + meta_lookup => sub { Class::MOP::class_of('Class::Vacuum::Innards') }, + with_meta => ['meta_lookup'], + ); + } +} + +{ + package Victim; + BEGIN { Class::Vacuum->import }; + + has star_rod => ( + is => 'ro', + ); + + ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); +} + +ok(Class::Vacuum::Innards->can('star_rod'), 'Vacuum stole the star_rod method'); +ok(!Victim->can('star_rod'), 'Victim does not get it at all'); + +{ + package Class::Vacuum::Reexport; + use Moose::Exporter; + + BEGIN { + Moose::Exporter->setup_import_methods(also => 'Class::Vacuum'); + } +} + +{ + package Victim2; + BEGIN { Class::Vacuum::Reexport->import } + + has parasol => ( + is => 'ro', + ); + + ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); +} + +ok(Class::Vacuum::Innards->can('parasol'), 'Vacuum stole the parasol method'); +ok(!Victim2->can('parasol'), 'Victim does not get it at all'); + +done_testing; diff --git a/t/metaclasses/exporter_sub_names.t b/t/metaclasses/exporter_sub_names.t new file mode 100644 index 0000000..628ed94 --- /dev/null +++ b/t/metaclasses/exporter_sub_names.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::CleanNamespaces; +use Test::More; + +diag "ALERT!!!!!! List::MoreUtils 0.407 is incompatible with Moose! You must upgrade or downgrade!" + if do { require List::MoreUtils; List::MoreUtils->VERSION eq '0.407' }; + +{ + package Metarole; + use Moose::Role; +} + +$::HAS_NC_AC = 0; + +{ + package Foo; + use Moose (); + use Moose::Exporter; + { + local $@; + eval 'use namespace::autoclean; $::HAS_NC_AC = 1'; + } + + Moose::Exporter->setup_import_methods( + also => 'Moose', + class_metaroles => { class => ['Metarole'] }, + ); + + my $meta = Class::MOP::Package->initialize(__PACKAGE__); + for my $name (qw( import unimport init_meta )) { + my $body = $meta->get_package_symbol( '&' . $name ); + my ( $package, $sub_name ) = Class::MOP::get_code_info($body); + + ::is( $package, __PACKAGE__, "$name sub is in Foo package" ); + ::is( $sub_name, $name, "$name sub has that name, not __ANON__" ); + } +} + +if ($::HAS_NC_AC) { + $INC{'Foo.pm'} = 1; + namespaces_clean('Foo'); +} + +done_testing(); + diff --git a/t/metaclasses/goto_moose_import.t b/t/metaclasses/goto_moose_import.t new file mode 100644 index 0000000..b6e70be --- /dev/null +++ b/t/metaclasses/goto_moose_import.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# Some packages out in the wild cooperate with Moose by using goto +# &Moose::import. we want to make sure it still works. + +{ + package MooseAlike1; + + use strict; + use warnings; + + use Moose (); + + sub import { + goto &Moose::import; + } + + sub unimport { + goto &Moose::unimport; + } +} + +{ + package Foo; + + MooseAlike1->import(); + + ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike1' ); + + MooseAlike1->unimport(); +} + +ok( ! Foo->can('has'), + 'No has sub in Foo after MooseAlike1 is unimported' ); +ok( Foo->can('meta'), + 'Foo has a meta method' ); +isa_ok( Foo->meta(), 'Moose::Meta::Class' ); + + +{ + package MooseAlike2; + + use strict; + use warnings; + + use Moose (); + + my $import = \&Moose::import; + sub import { + goto $import; + } + + my $unimport = \&Moose::unimport; + sub unimport { + goto $unimport; + } +} + +{ + package Bar; + + MooseAlike2->import(); + + ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike2' ); + + MooseAlike2->unimport(); +} + + +ok( ! Bar->can('has'), + 'No has sub in Bar after MooseAlike2 is unimported' ); +ok( Bar->can('meta'), + 'Bar has a meta method' ); +isa_ok( Bar->meta(), 'Moose::Meta::Class' ); + +done_testing; diff --git a/t/metaclasses/immutable_metaclass_compat_bug.t b/t/metaclasses/immutable_metaclass_compat_bug.t new file mode 100644 index 0000000..67a4ffa --- /dev/null +++ b/t/metaclasses/immutable_metaclass_compat_bug.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Base::Meta::Trait; + use Moose::Role; +} + +{ + package Foo::Base; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Base::Meta::Trait'] }, + ); + __PACKAGE__->meta->make_immutable; +} + +{ + package Foo::Meta::Trait; + use Moose::Role; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Trait'] } + ); + ::ok(!Foo->meta->is_immutable); + extends 'Foo::Base'; + ::ok(!Foo->meta->is_immutable); +} + +done_testing; diff --git a/t/metaclasses/meta_name.t b/t/metaclasses/meta_name.t new file mode 100644 index 0000000..d947a18 --- /dev/null +++ b/t/metaclasses/meta_name.t @@ -0,0 +1,73 @@ +use strict; +use warnings; +use Test::More; + +{ + # so we don't pick up stuff from Moose::Object + package Base; + sub foo { } # touch it so that 'extends' doesn't try to load it +} + +{ + package Foo; + use Moose; + extends 'Base'; + no Moose; +} +can_ok('Foo', 'meta'); +is(Foo->meta, Class::MOP::class_of('Foo'), 'Foo is a class_of Foo, via Foo->meta'); +isa_ok(Foo->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); + +{ + package Bar; + use Moose -meta_name => 'bar_meta'; + extends 'Base'; + no Moose; +} +ok(!Bar->can('meta'), q{Bar->cant('meta')}); +can_ok('Bar', 'bar_meta'); +is(Bar->bar_meta, Class::MOP::class_of('Bar'), 'Bar is a class_of Bar, via Bar->bar_meta'); +isa_ok(Bar->bar_meta->get_method('bar_meta'), 'Moose::Meta::Method::Meta'); + +{ + package Baz; + use Moose -meta_name => undef; + extends 'Base'; + no Moose; +} +ok(!Baz->can('meta'), q{Baz->cant('meta')}); + +my $universal_method_count = scalar Class::MOP::class_of('UNIVERSAL')->get_all_methods; +# 1 because of the dummy method we installed in Base +is( + ( scalar Class::MOP::class_of('Baz')->get_all_methods ) - $universal_method_count, + 1, + 'Baz has one method', +); + +{ + package Qux; + use Moose -meta_name => 'qux_meta'; +} + +can_ok('Qux', 'qux_meta'); +is(Qux->qux_meta, Class::MOP::class_of('Qux'), 'Qux is a class_of Qux, via Qux->qux_meta'); +isa_ok(Qux->qux_meta->get_method('qux_meta'), 'Moose::Meta::Method::Meta'); + +{ + package FooBar; + sub meta { 42 } + use Moose -meta_name => 'foo_bar_meta'; +} + +is(FooBar->meta, 42, 'FooBar->meta returns 42, not metaclass object'); + +{ + package FooBar::Child; + use Moose -meta_name => 'foo_bar_child_meta'; + extends 'FooBar'; +} + +is(FooBar::Child->meta, 42, 'FooBar::Child->meta returns 42, not metaclass object'); + +done_testing; diff --git a/t/metaclasses/metaclass_compat.t b/t/metaclasses/metaclass_compat.t new file mode 100644 index 0000000..8ef2343 --- /dev/null +++ b/t/metaclasses/metaclass_compat.t @@ -0,0 +1,304 @@ +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +our $called = 0; +{ + package Foo::Trait::Class; + use Moose::Role; + + around _inline_BUILDALL => sub { + my $orig = shift; + my $self = shift; + return ( + $self->$orig(@_), + '$::called++;' + ); + } +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + class => ['Foo::Trait::Class'], + } + ); +} + +Foo->new; +is($called, 0, "no calls before inlining"); +Foo->meta->make_immutable; + +Foo->new; +is($called, 1, "inlined constructor has trait modifications"); + +ok(Foo->meta->meta->does_role('Foo::Trait::Class'), + "class has correct traits"); + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; +} + +$called = 0; + +Foo::Sub->new; +is($called, 0, "no calls before inlining"); + +Foo::Sub->meta->make_immutable; + +Foo::Sub->new; +is($called, 1, "inherits trait properly"); + +ok(Foo::Sub->meta->meta->can('does_role') +&& Foo::Sub->meta->meta->does_role('Foo::Trait::Class'), + "subclass inherits traits"); + +{ + package Foo2::Role; + use Moose::Role; +} +{ + package Foo2; + use Moose -traits => ['Foo2::Role']; +} +{ + package Bar2; + use Moose; +} +{ + package Baz2; + use Moose; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is( ::exception { $meta->superclasses('Bar2') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role'], + "still have the role attached"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Foo3::Role; + use Moose::Role; +} +{ + package Bar3; + use Moose -traits => ['Foo3::Role']; +} +{ + package Baz3; + use Moose -traits => ['Foo3::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Bar3') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar3->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Quux3; + use Moose; +} +{ + package Quuux3; + use Moose -traits => ['Foo3::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Quux3') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Quux3->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} + +{ + package Foo4::Role; + use Moose::Role; +} +{ + package Foo4; + use Moose -traits => ['Foo4::Role']; + __PACKAGE__->meta->make_immutable; +} +{ + package Bar4; + use Moose; +} +{ + package Baz4; + use Moose; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is( ::exception { $meta->superclasses('Bar4') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar4->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role'], + "still have the role attached"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Foo5::Role; + use Moose::Role; +} +{ + package Bar5; + use Moose -traits => ['Foo5::Role']; +} +{ + package Baz5; + use Moose -traits => ['Foo5::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Bar5') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar5->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Quux5; + use Moose; +} +{ + package Quuux5; + use Moose -traits => ['Foo5::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Quux5') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Quux5->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} + +{ + package Foo5::Meta::Role; + use Moose::Role; +} +{ + package Foo5::SuperClass::WithMetaRole; + use Moose -traits =>'Foo5::Meta::Role'; +} +{ + package Foo5::SuperClass::After::Attribute; + use Moose; +} +{ + package Foo5; + use Moose; + my @superclasses = ('Foo5::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo5::SuperClass::After::Attribute'); + + ::is( ::exception { + extends @superclasses; + }, undef, 'MI extends after_generated_methods with metaclass roles' ); + ::is( ::exception { + extends reverse @superclasses; + }, undef, 'MI extends after_generated_methods with metaclass roles (reverse)' ); +} + +{ + package Foo6::Meta::Role; + use Moose::Role; +} +{ + package Foo6::SuperClass::WithMetaRole; + use Moose -traits =>'Foo6::Meta::Role'; +} +{ + package Foo6::Meta::OtherRole; + use Moose::Role; +} +{ + package Foo6::SuperClass::After::Attribute; + use Moose -traits =>'Foo6::Meta::OtherRole'; +} +{ + package Foo6; + use Moose; + my @superclasses = ('Foo6::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo6::SuperClass::After::Attribute'); + + ::like( ::exception { + extends @superclasses; + }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles' ); + ::like( ::exception { + extends reverse @superclasses; + }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles (reverse)' ); +} + +{ + package Foo7::Meta::Trait; + use Moose::Role; +} + +{ + package Foo7; + use Moose -traits => ['Foo7::Meta::Trait']; +} + +{ + package Bar7; + # in an external file + use Moose -traits => ['Bar7::Meta::Trait']; + ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); +} + +{ + package Bar72; + # in an external file + use Moose -traits => ['Bar7::Meta::Trait2']; + ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); +} + +done_testing; diff --git a/t/metaclasses/metaclass_compat_no_fixing_bug.t b/t/metaclasses/metaclass_compat_no_fixing_bug.t new file mode 100644 index 0000000..19ec76a --- /dev/null +++ b/t/metaclasses/metaclass_compat_no_fixing_bug.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo::Meta::Constructor1; + use Moose::Role; +} + +{ + package Foo::Meta::Constructor2; + use Moose::Role; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor1'] }, + ); +} + +{ + package Foo::Sub; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, + ); + extends 'Foo'; +} + +{ + package Foo::Sub::Sub; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, + ); + ::is( ::exception { extends 'Foo::Sub' }, undef, "doesn't try to fix if nothing is needed" ); +} + +done_testing; diff --git a/t/metaclasses/metaclass_compat_role_conflicts.t b/t/metaclasses/metaclass_compat_role_conflicts.t new file mode 100644 index 0000000..13cd150 --- /dev/null +++ b/t/metaclasses/metaclass_compat_role_conflicts.t @@ -0,0 +1,63 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package My::Meta::Role1; + use Moose::Role; + sub foo { 'Role1' } +} +BEGIN { + package My::Meta::Role2; + use Moose::Role; + with 'My::Meta::Role1'; + sub foo { 'Role2' } +} +BEGIN { + package My::Extension; + use Moose::Exporter; + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['My::Meta::Role2'], + }, + ); + $INC{'My/Extension.pm'} = __FILE__; +} +BEGIN { + package My::Meta::Role3; + use Moose::Role; +} +BEGIN { + package My::Extension2; + use Moose::Exporter; + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['My::Meta::Role3'], + }, + ); + $INC{'My/Extension2.pm'} = __FILE__; +} + +{ + package My::Class1; + use Moose; + use My::Extension; +} + +is(My::Class1->new->meta->foo, 'Role2'); + +{ + package My::Class2; + use Moose; + use My::Extension2; +} +{ + package My::Class3; + use Moose; + use My::Extension; + extends 'My::Class2'; +} + +is(My::Class3->new->meta->foo, 'Role2'); + +done_testing; diff --git a/t/metaclasses/metaclass_parameterized_traits.t b/t/metaclasses/metaclass_parameterized_traits.t new file mode 100644 index 0000000..ca4b5a9 --- /dev/null +++ b/t/metaclasses/metaclass_parameterized_traits.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More; + +{ + package My::Trait; + use Moose::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Moose -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'enam', + }, + }, + ]; +} + +{ + package My::Other::Class; + use Moose -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'reversed', + }, + -excludes => 'reversed_name', + }, + ]; +} + +my $meta = My::Class->meta; +is($meta->enam, 'ssalC::yM', 'parameterized trait applied'); +ok(!$meta->can('reversed'), "the method was not installed under the other class' alias"); + +my $other_meta = My::Other::Class->meta; +is($other_meta->reversed, 'ssalC::rehtO::yM', 'parameterized trait applied'); +ok(!$other_meta->can('enam'), "the method was not installed under the other class' alias"); +ok(!$other_meta->can('reversed_name'), "the method was not installed under the original name when that was excluded"); + +done_testing; diff --git a/t/metaclasses/metaclass_traits.t b/t/metaclasses/metaclass_traits.t new file mode 100644 index 0000000..bcb9f90 --- /dev/null +++ b/t/metaclasses/metaclass_traits.t @@ -0,0 +1,224 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +{ + package My::SimpleTrait; + + use Moose::Role; + + sub simple { return 5 } +} + +{ + package Foo; + + use Moose -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Foo->meta(), 'simple' ); +is( Foo->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package Bar; + + use Moose -traits => 'My::SimpleTrait'; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package My::SimpleTrait2; + + use Moose::Role; + + # This needs to happen at compile time so it happens before we + # apply traits to Bar + BEGIN { + has 'attr' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple { return 5 } +} + +{ + package Bar; + + use Moose -traits => [ 'My::SimpleTrait2' ]; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Bar->meta()->simple() returns expected value' ); +can_ok( Bar->meta(), 'attr' ); +is( Bar->meta()->attr(), 'something', + 'Bar->meta()->attr() returns expected value' ); + +{ + package My::SimpleTrait3; + + use Moose::Role; + + BEGIN { + has 'attr2' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple2 { return 55 } +} + +{ + package Baz; + + use Moose -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ]; +} + +can_ok( Baz->meta(), 'simple' ); +is( Baz->meta()->simple(), 5, + 'Baz->meta()->simple() returns expected value' ); +can_ok( Baz->meta(), 'attr' ); +is( Baz->meta()->attr(), 'something', + 'Baz->meta()->attr() returns expected value' ); +can_ok( Baz->meta(), 'simple2' ); +is( Baz->meta()->simple2(), 55, + 'Baz->meta()->simple2() returns expected value' ); +can_ok( Baz->meta(), 'attr2' ); +is( Baz->meta()->attr2(), 'something', + 'Baz->meta()->attr2() returns expected value' ); + +{ + package My::Trait::AlwaysRO; + + use Moose::Role; + + around '_process_new_attribute', '_process_inherited_attribute' => + sub { + my $orig = shift; + my ( $self, $name, %args ) = @_; + + $args{is} = 'ro'; + + return $self->$orig( $name, %args ); + }; +} + +{ + package Quux; + + use Moose -traits => [ 'My::Trait::AlwaysRO' ]; + + has 'size' => + ( is => 'rw', + isa => 'Int', + ); +} + +ok( Quux->meta()->has_attribute('size'), + 'Quux has size attribute' ); +ok( ! Quux->meta()->get_attribute('size')->writer(), + 'size attribute does not have a writer' ); + +{ + package My::Class::Whatever; + + use Moose::Role; + + sub whatever { 42 } + + package Moose::Meta::Class::Custom::Trait::Whatever; + + sub register_implementation { + return 'My::Class::Whatever'; + } +} + +{ + package RanOutOfNames; + + use Moose -traits => [ 'Whatever' ]; +} + +ok( RanOutOfNames->meta()->meta()->has_method('whatever'), + 'RanOutOfNames->meta() has whatever method' ); + +{ + package Role::Foo; + + use Moose::Role -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Role::Foo->meta(), 'simple' ); +is( Role::Foo->meta()->simple(), 5, + 'Role::Foo->meta()->simple() returns expected value' ); + +{ + require Moose::Util::TypeConstraints; + like( + exception { + Moose::Util::TypeConstraints->import( + -traits => 'My::SimpleTrait' ); + }, + qr/does not have an init_meta/, + 'cannot provide -traits to an exporting module that does not init_meta' + ); +} + +{ + package Foo::Subclass; + + use Moose -traits => [ 'My::SimpleTrait3' ]; + + extends 'Foo'; +} + +can_ok( Foo::Subclass->meta(), 'simple' ); +is( Foo::Subclass->meta()->simple(), 5, + 'Foo::Subclass->meta()->simple() returns expected value' ); +is( Foo::Subclass->meta()->simple2(), 55, + 'Foo::Subclass->meta()->simple2() returns expected value' ); +can_ok( Foo::Subclass->meta(), 'attr2' ); +is( Foo::Subclass->meta()->attr2(), 'something', + 'Foo::Subclass->meta()->attr2() returns expected value' ); + +{ + + package Class::WithAlreadyPresentTrait; + use Moose -traits => 'My::SimpleTrait'; + + has an_attr => ( is => 'ro' ); +} + +is( exception { + my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +}, undef, 'Can create instance and access attributes' ); + +{ + + package Class::WhichLoadsATraitFromDisk; + + # Any role you like here, the only important bit is that it gets + # loaded from disk and has not already been defined. + use Moose -traits => 'Role::Parent'; + + has an_attr => ( is => 'ro' ); +} + +is( exception { + my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +}, undef, 'Can create instance and access attributes' ); + +done_testing; diff --git a/t/metaclasses/metarole.t b/t/metaclasses/metarole.t new file mode 100644 index 0000000..40f2420 --- /dev/null +++ b/t/metaclasses/metarole.t @@ -0,0 +1,725 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +use Moose::Util::MetaRole; + + +{ + package My::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; +} + +{ + package Role::Foo; + use Moose::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use Moose; +} + +{ + package My::Role; + use Moose::Role; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => My::Class->meta, + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class->meta()' ); + is( My::Class->meta()->foo(), 10, + '... and call foo() on that meta object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { attribute => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s attribute metaclass} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + + My::Class->meta()->add_attribute( 'size', is => 'ro' ); + is( My::Class->meta()->get_attribute('size')->foo(), 10, + '... call foo() on an attribute metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { method => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s method metaclass} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + + My::Class->meta()->add_method( 'bar' => sub { 'bar' } ); + is( My::Class->meta()->get_method('bar')->foo(), 10, + '... call foo() on a method metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { wrapped_method => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s wrapped method metaclass} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + + My::Class->meta()->add_after_method_modifier( 'bar' => sub { 'bar' } ); + is( My::Class->meta()->get_method('bar')->foo(), 10, + '... call foo() on a wrapped method metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { instance => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s instance metaclass} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s method metaclass still does Role::Foo} ); + + is( My::Class->meta()->get_meta_instance()->foo(), 10, + '... call foo() on an instance metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { constructor => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s constructor class} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s method metaclass still does Role::Foo} ); + ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); + + # Actually instantiating the constructor class is too freaking hard! + ok( My::Class->meta()->constructor_class()->can('foo'), + '... constructor class has a foo method' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { destructor => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s destructor class} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s method metaclass still does Role::Foo} ); + ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); + ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s constructor class still does Role::Foo} ); + + # same problem as the constructor class + ok( My::Class->meta()->destructor_class()->can('foo'), + '... destructor class has a foo method' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_class => ['Role::Foo'] }, + ); + + ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), + q{apply Role::Foo to My::Role->meta's application_to_class class} ); + + is( My::Role->meta->application_to_class_class->new->foo, 10, + q{... call foo() on an application_to_class instance} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_role => ['Role::Foo'] }, + ); + + ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), + q{apply Role::Foo to My::Role->meta's application_to_role class} ); + ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), + q{... My::Role->meta's application_to_class class still does Role::Foo} ); + + is( My::Role->meta->application_to_role_class->new->foo, 10, + q{... call foo() on an application_to_role instance} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_instance => ['Role::Foo'] }, + ); + + ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'), + q{apply Role::Foo to My::Role->meta's application_to_instance class} ); + ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), + q{... My::Role->meta's application_to_role class still does Role::Foo} ); + ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), + q{... My::Role->meta's application_to_class class still does Role::Foo} ); + + is( My::Role->meta->application_to_instance_class->new->foo, 10, + q{... call foo() on an application_to_instance instance} ); +} + +{ + Moose::Util::MetaRole::apply_base_class_roles( + for => 'My::Class', + roles => ['Role::Foo'], + ); + + ok( My::Class->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class base class' ); + is( My::Class->new()->foo(), 10, + '... call foo() on a My::Class object' ); +} + +{ + package My::Class2; + + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class2', + class_metaroles => { + class => ['Role::Foo'], + attribute => ['Role::Foo'], + method => ['Role::Foo'], + instance => ['Role::Foo'], + constructor => ['Role::Foo'], + destructor => ['Role::Foo'], + }, + ); + + ok( My::Class2->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class2->meta()' ); + is( My::Class2->meta()->foo(), 10, + '... and call foo() on that meta object' ); + ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); + My::Class2->meta()->add_attribute( 'size', is => 'ro' ); + + is( My::Class2->meta()->get_attribute('size')->foo(), 10, + '... call foo() on an attribute metaclass object' ); + + ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); + + My::Class2->meta()->add_method( 'bar' => sub { 'bar' } ); + is( My::Class2->meta()->get_method('bar')->foo(), 10, + '... call foo() on a method metaclass object' ); + + ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); + is( My::Class2->meta()->get_meta_instance()->foo(), 10, + '... call foo() on an instance metaclass object' ); + + ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s constructor class} ); + ok( My::Class2->meta()->constructor_class()->can('foo'), + '... constructor class has a foo method' ); + + ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s destructor class} ); + ok( My::Class2->meta()->destructor_class()->can('foo'), + '... destructor class has a foo method' ); +} + + +{ + package My::Meta; + + use Moose::Exporter; + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + my %p = @_; + + Moose->init_meta( %p, metaclass => 'My::Meta::Class' ); + } +} + +{ + package My::Class3; + + My::Meta->import(); +} + + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class3', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class3->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class3->meta()' ); + is( My::Class3->meta()->foo(), 10, + '... and call foo() on that meta object' ); + ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ), + 'apply_metaroles() does not interfere with metaclass set via Moose->init_meta()' ); +} + +{ + package Role::Bar; + use Moose::Role; + has 'bar' => ( is => 'ro', default => 200 ); +} + +{ + package My::Class4; + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class4', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class4->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class4->meta()' ); + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class4', + class_metaroles => { class => ['Role::Bar'] }, + ); + + ok( My::Class4->meta()->meta()->does_role('Role::Bar'), + 'apply Role::Bar to My::Class4->meta()' ); + ok( My::Class4->meta()->meta()->does_role('Role::Foo'), + '... and My::Class4->meta() still does Role::Foo' ); +} + +{ + package My::Class5; + use Moose; + + extends 'My::Class'; +} + +{ + ok( My::Class5->meta()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s does Role::Foo because it extends My::Class} ); + ok( My::Class5->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s attribute metaclass also does Role::Foo} ); + ok( My::Class5->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s method metaclass also does Role::Foo} ); + ok( My::Class5->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s instance metaclass also does Role::Foo} ); + ok( My::Class5->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s constructor class also does Role::Foo} ); + ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s destructor class also does Role::Foo} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class5', + class_metaroles => { class => ['Role::Bar'] }, + ); + + ok( My::Class5->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class5->meta()} ); + ok( My::Class5->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class5->meta() still does Role::Foo} ); +} + +{ + package My::Class6; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class6', + class_metaroles => { class => ['Role::Bar'] }, + ); + + extends 'My::Class'; +} + +{ + ok( My::Class6->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class6->meta() before extends} ); + ok( My::Class6->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} ); +} + +# This is the hack that used to be needed to work around the +# _fix_metaclass_incompatibility problem. You called extends() (which +# in turn calls _fix_metaclass_imcompatibility) _before_ you apply +# more extensions in the subclass. We wabt to make sure this continues +# to work in the future. +{ + package My::Class7; + use Moose; + + # In real usage this would go in a BEGIN block so it happened + # before apply_metaroles was called by an extension. + extends 'My::Class'; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class7', + class_metaroles => { class => ['Role::Bar'] }, + ); +} + +{ + ok( My::Class7->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class7->meta() before extends} ); + ok( My::Class7->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} ); +} + +{ + package My::Class8; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class8', + class_metaroles => { + class => ['Role::Bar'], + attribute => ['Role::Bar'], + }, + ); + + extends 'My::Class'; +} + +{ + ok( My::Class8->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class8->meta() before extends} ); + ok( My::Class8->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} ); + ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), + q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} ); + ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), + q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} ); +} + + +{ + package My::Class9; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class9', + class_metaroles => { attribute => ['Role::Bar'] }, + ); + + extends 'My::Class'; +} + +{ + ok( My::Class9->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} ); + ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), + q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} ); + ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), + q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} ); +} + +# This tests applying meta roles to a metaclass's metaclass. This is +# completely insane, but is exactly what happens with +# Fey::Meta::Class::Table. It's a subclass of Moose::Meta::Class +# itself, and then it _uses_ MooseX::ClassAttribute, so the metaclass +# for Fey::Meta::Class::Table does a role. +# +# At one point this caused a metaclass incompatibility error down +# below, when we applied roles to the metaclass of My::Class10. It's +# all madness but as long as the tests pass we're happy. +{ + package My::Meta::Class2; + use Moose; + extends 'Moose::Meta::Class'; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Meta::Class2', + class_metaroles => { class => ['Role::Foo'] }, + ); +} + +{ + package My::Object; + use Moose; + extends 'Moose::Object'; +} + +{ + package My::Meta2; + + use Moose::Exporter; + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + my %p = @_; + + Moose->init_meta( + %p, + metaclass => 'My::Meta::Class2', + base_class => 'My::Object', + ); + } +} + +{ + package My::Class10; + My::Meta2->import; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class10', + class_metaroles => { class => ['Role::Bar'] }, + ); +} + +{ + ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'), + q{My::Class10->meta()->meta() does Role::Foo } ); + ok( My::Class10->meta()->meta()->does_role('Role::Bar'), + q{My::Class10->meta()->meta() does Role::Bar } ); + ok( My::Class10->meta()->isa('My::Meta::Class2'), + q{... and My::Class10->meta still isa(My::Meta::Class2)} ); + ok( My::Class10->isa('My::Object'), + q{... and My::Class10 still isa(My::Object)} ); +} + +{ + package My::Constructor; + + use parent 'Moose::Meta::Method::Constructor'; +} + +{ + package My::Class11; + + use Moose; + + __PACKAGE__->meta->constructor_class('My::Constructor'); + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class11', + class_metaroles => { class => ['Role::Foo'] }, + ); +} + +{ + ok( My::Class11->meta()->meta()->does_role('Role::Foo'), + q{My::Class11->meta()->meta() does Role::Foo } ); + is( My::Class11->meta()->constructor_class, 'My::Constructor', + q{... and explicitly set constructor_class value is unchanged)} ); +} + +{ + package ExportsMoose; + + Moose::Exporter->setup_import_methods( + also => 'Moose', + ); + + sub init_meta { + shift; + my %p = @_; + Moose->init_meta(%p); + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + # Causes us to recurse through init_meta, as we have to + # load MyMetaclassRole from disk. + class_metaroles => { class => [qw/MyMetaclassRole/] }, + ); + } +} + +is( exception { + package UsesExportedMoose; + ExportsMoose->import; +}, undef, 'import module which loads a role from disk during init_meta' ); + +{ + package Foo::Meta::Role; + + use Moose::Role; +} + +{ + package Foo::Role; + + Moose::Exporter->setup_import_methods( + also => 'Moose::Role', + ); + + sub init_meta { + shift; + my %p = @_; + + Moose::Role->init_meta(%p); + + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + role_metaroles => { method => ['Foo::Meta::Role'] }, + ); + } +} + +{ + package Role::Baz; + + Foo::Role->import; + + sub bla {} +} + +{ + package My::Class12; + + use Moose; + + with( 'Role::Baz' ); +} + +{ + ok( + My::Class12->meta->does_role( 'Role::Baz' ), + 'role applied' + ); + + my $method = My::Class12->meta->get_method( 'bla' ); + ok( + $method->meta->does_role( 'Foo::Meta::Role' ), + 'method_metaclass_role applied' + ); +} + +{ + package Parent; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Role::Foo'] }, + ); +} + +{ + package Child; + + use Moose; + extends 'Parent'; +} + +{ + ok( + Parent->meta->constructor_class->meta->can('does_role') + && Parent->meta->constructor_class->meta->does_role('Role::Foo'), + 'Parent constructor class has metarole from Parent' + ); + + ok( + Child->meta->constructor_class->meta->can('does_role') + && Child->meta->constructor_class->meta->does_role( + 'Role::Foo'), + 'Child constructor class has metarole from Parent' + ); +} + +{ + package NotMoosey; + + use metaclass; +} + +{ + like( + exception { + Moose::Util::MetaRole::apply_metaroles( + for => 'Does::Not::Exist', + class_metaroles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed Does::Not::Exist.+Maybe you need to call.+/, + 'useful error when apply metaroles to a class without a metaclass' + ); + + like( + exception { + Moose::Util::MetaRole::apply_metaroles( + for => 'NotMoosey', + class_metaroles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, + 'useful error when using apply metaroles to a class with a Class::MOP::Class metaclass' + ); + + like( + exception { + Moose::Util::MetaRole::apply_base_class_roles( + for => 'NotMoosey', + roles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, + 'useful error when applying base class to roles to a non-Moose class' + ); + + like( + exception { + Moose::Util::MetaRole::apply_base_class_roles( + for => 'My::Role', + roles => { class => ['Role::Foo'] }, + ); + }, + qr/You can only apply base class roles to a Moose class.+/, + 'useful error when applying base class to roles to a non-Moose class' + ); +} + +done_testing; diff --git a/t/metaclasses/metarole_combination.t b/t/metaclasses/metarole_combination.t new file mode 100644 index 0000000..31a8ed8 --- /dev/null +++ b/t/metaclasses/metarole_combination.t @@ -0,0 +1,238 @@ +use strict; +use warnings; +use Test::More; + +our @applications; + +{ + package CustomApplication; + use Moose::Role; + + after apply_methods => sub { + my ( $self, $role, $other ) = @_; + $self->apply_custom( $role, $other ); + }; + + sub apply_custom { + shift; + push @applications, [@_]; + } +} + +{ + package CustomApplication::ToClass; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToRole; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToInstance; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::Composite; + use Moose::Role; + + with 'CustomApplication'; + + around apply_custom => sub { + my ( $next, $self, $composite, $other ) = @_; + for my $role ( @{ $composite->get_roles } ) { + $self->$next( $role, $other ); + } + }; +} + +{ + package CustomApplication::Composite::ToClass; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToRole; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToInstance; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package Role::Composite; + use Moose::Role; + + around apply_params => sub { + my ( $next, $self, @args ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for => $self->$next(@args), + role_metaroles => { + application_to_class => + ['CustomApplication::Composite::ToClass'], + application_to_role => + ['CustomApplication::Composite::ToRole'], + application_to_instance => + ['CustomApplication::Composite::ToInstance'], + }, + ); + }; +} + +{ + package Role::WithCustomApplication; + use Moose::Role; + + around composition_class_roles => sub { + my ($orig, $self) = @_; + return $self->$orig, 'Role::Composite'; + }; +} + +{ + package CustomRole; + Moose::Exporter->setup_import_methods( + also => 'Moose::Role', + ); + + sub init_meta { + my ( $self, %options ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for => Moose::Role->init_meta(%options), + role_metaroles => { + role => ['Role::WithCustomApplication'], + application_to_class => + ['CustomApplication::ToClass'], + application_to_role => ['CustomApplication::ToRole'], + application_to_instance => + ['CustomApplication::ToInstance'], + }, + ); + } +} + +{ + package My::Role::Normal; + use Moose::Role; +} + +{ + package My::Role::Special; + CustomRole->import; +} + +ok( My::Role::Normal->meta->isa('Moose::Meta::Role'), "sanity check" ); +ok( My::Role::Special->meta->isa('Moose::Meta::Role'), + "using custom application roles does not change the role metaobject's class" +); +ok( My::Role::Special->meta->meta->does_role('Role::WithCustomApplication'), + "the role's metaobject has custom applications" ); +is_deeply( [My::Role::Special->meta->composition_class_roles], + ['Role::Composite'], + "the role knows about the specified composition class" ); + +{ + package Foo; + use Moose; + + local @applications; + with 'My::Role::Special'; + + ::is( @applications, 1, 'one role application' ); + ::is( $applications[0]->[0]->name, 'My::Role::Special', + "the application's first role was My::Role::Special'" ); + ::is( $applications[0]->[1]->name, 'Foo', + "the application provided an additional role" ); +} + +{ + package Bar; + use Moose::Role; + + local @applications; + with 'My::Role::Special'; + + ::is( @applications, 1 ); + ::is( $applications[0]->[0]->name, 'My::Role::Special' ); + ::is( $applications[0]->[1]->name, 'Bar' ); +} + +{ + package Baz; + use Moose; + + my $i = Baz->new; + local @applications; + My::Role::Special->meta->apply($i); + + ::is( @applications, 1 ); + ::is( $applications[0]->[0]->name, 'My::Role::Special' ); + ::ok( $applications[0]->[1]->is_anon_class ); + ::ok( $applications[0]->[1]->name->isa('Baz') ); +} + +{ + package Corge; + use Moose; + + local @applications; + with 'My::Role::Normal', 'My::Role::Special'; + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::is( $applications[0]->[1]->name, 'Corge' ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::is( $applications[1]->[1]->name, 'Corge' ); +} + +{ + package Thud; + use Moose::Role; + + local @applications; + with 'My::Role::Normal', 'My::Role::Special'; + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::is( $applications[0]->[1]->name, 'Thud' ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::is( $applications[1]->[1]->name, 'Thud' ); +} + +{ + package Garply; + use Moose; + + my $i = Garply->new; + local @applications; + Moose::Meta::Role->combine( + [ 'My::Role::Normal' => undef ], + [ 'My::Role::Special' => undef ], + )->apply($i); + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::ok( $applications[0]->[1]->is_anon_class ); + ::ok( $applications[0]->[1]->name->isa('Garply') ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::ok( $applications[1]->[1]->is_anon_class ); + ::ok( $applications[1]->[1]->name->isa('Garply') ); +} + +done_testing; diff --git a/t/metaclasses/metarole_on_anon.t b/t/metaclasses/metarole_on_anon.t new file mode 100644 index 0000000..816e6b4 --- /dev/null +++ b/t/metaclasses/metarole_on_anon.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Class; +use Moose::Util::MetaRole; + +{ + package Foo; + use Moose; +} + +{ + package Role::Bar; + use Moose::Role; +} + +my $anon_name; + +{ + my $anon_class = Moose::Meta::Class->create_anon_class( + superclasses => ['Foo'], + cache => 1, + ); + + $anon_name = $anon_class->name; + + ok( $anon_name->meta, 'anon class has a metaclass' ); +} + +ok( + $anon_name->meta, + 'cached anon class still has a metaclass after \$anon_class goes out of scope' +); + +Moose::Util::MetaRole::apply_metaroles( + for => $anon_name, + class_metaroles => { + class => ['Role::Bar'], + }, +); + +BAIL_OUT('Cannot continue if the anon class does not have a metaclass') + unless $anon_name->can('meta'); + +my $meta = $anon_name->meta; +ok( $meta, 'cached anon class still has a metaclass applying a metarole' ); + +done_testing; diff --git a/t/metaclasses/metarole_w_metaclass_pm.t b/t/metaclasses/metarole_w_metaclass_pm.t new file mode 100644 index 0000000..c47a208 --- /dev/null +++ b/t/metaclasses/metarole_w_metaclass_pm.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::MetaRole; + +BEGIN +{ + package My::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; +} + +BEGIN +{ + package My::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; +} + +BEGIN +{ + package My::Meta::Method; + use Moose; + extends 'Moose::Meta::Method'; +} + +BEGIN +{ + package My::Meta::Instance; + use Moose; + extends 'Moose::Meta::Instance'; +} + +BEGIN +{ + package Role::Foo; + use Moose::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use metaclass 'My::Meta::Class'; + use Moose; +} + +{ + package My::Class2; + + use metaclass 'My::Meta::Class' => ( + attribute_metaclass => 'My::Meta::Attribute', + method_metaclass => 'My::Meta::Method', + instance_metaclass => 'My::Meta::Instance', + ); + + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class->meta()' ); + has_superclass( My::Class->meta(), 'My::Meta::Class', + 'apply_metaroles works with metaclass.pm' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class2', + class_metaroles => { + attribute => ['Role::Foo'], + method => ['Role::Foo'], + instance => ['Role::Foo'], + }, + ); + + ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); + has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute', + '... and this does not interfere with attribute metaclass set via metaclass.pm' ); + ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); + has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method', + '... and this does not interfere with method metaclass set via metaclass.pm' ); + ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); + has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance', + '... and this does not interfere with instance metaclass set via metaclass.pm' ); +} + +# like isa_ok but works with a class name, not just refs +sub has_superclass { + my $thing = shift; + my $parent = shift; + my $desc = shift; + + my %supers = map { $_ => 1 } $thing->meta()->superclasses(); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + ok( $supers{$parent}, $desc ); +} + +done_testing; diff --git a/t/metaclasses/metaroles_of_metaroles.t b/t/metaclasses/metaroles_of_metaroles.t new file mode 100644 index 0000000..d8533c7 --- /dev/null +++ b/t/metaclasses/metaroles_of_metaroles.t @@ -0,0 +1,67 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package ApplicationMetaRole; + use Moose::Role; + use Moose::Util::MetaRole; + + after apply => sub { + my ($self, $role_source, $role_dest, $args) = @_; + Moose::Util::MetaRole::apply_metaroles + ( + for => $role_dest, + role_metaroles => + { + application_to_role => ['ApplicationMetaRole'], + } + ); + }; +} +{ + package MyMetaRole; + use Moose::Role; + use Moose::Util::MetaRole; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods(also => q<Moose::Role>); + + sub init_meta { + my ($class, %opts) = @_; + Moose::Role->init_meta(%opts); + Moose::Util::MetaRole::apply_metaroles + ( + for => $opts{for_class}, + role_metaroles => + { + application_to_role => ['ApplicationMetaRole'], + } + ); + return $opts{for_class}->meta(); + }; +} + +{ + package MyRole; + use Moose::Role; + + MyMetaRole->import; + + use Moose::Util::TypeConstraints; + + has schema => ( + is => 'ro', + coerce => 1, + ); +} + +{ + package MyTargetRole; + use Moose::Role; + ::is(::exception { with "MyRole" }, undef, + "apply a meta role to a role, which is then applied to yet another role"); +} + +done_testing; diff --git a/t/metaclasses/moose_exporter.t b/t/metaclasses/moose_exporter.t new file mode 100644 index 0000000..dde583a --- /dev/null +++ b/t/metaclasses/moose_exporter.t @@ -0,0 +1,677 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package HasOwnImmutable; + + use Moose; + + no Moose; + + ::stderr_is( sub { eval q[sub make_immutable { return 'foo' }] }, + '', + 'no warning when defining our own make_immutable sub' ); +} + +{ + is( HasOwnImmutable->make_immutable(), 'foo', + 'HasOwnImmutable->make_immutable does not get overwritten' ); +} + +{ + package MooseX::Empty; + + use Moose (); + Moose::Exporter->setup_import_methods( also => 'Moose' ); +} + +{ + package WantsMoose; + + MooseX::Empty->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMoose', 'has' ); + ::can_ok( 'WantsMoose', 'with' ); + ::can_ok( 'WantsMoose', 'foo' ); + + MooseX::Empty->unimport(); +} + +{ + # Note: it's important that these methods be out of scope _now_, + # after unimport was called. We tried a + # namespace::clean(0.08)-based solution, but had to abandon it + # because it cleans the namespace _later_ (when the file scope + # ends). + ok( ! WantsMoose->can('has'), 'WantsMoose::has() has been cleaned' ); + ok( ! WantsMoose->can('with'), 'WantsMoose::with() has been cleaned' ); + can_ok( 'WantsMoose', 'foo' ); + + # This makes sure that Moose->init_meta() happens properly + isa_ok( WantsMoose->meta(), 'Moose::Meta::Class' ); + isa_ok( WantsMoose->new(), 'Moose::Object' ); + +} + +{ + package MooseX::Sugar; + + use Moose (); + + sub wrapped1 { + my $meta = shift; + return $meta->name . ' called wrapped1'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['wrapped1'], + also => 'Moose', + ); +} + +{ + package WantsSugar; + + MooseX::Sugar->import(); + + sub foo { 1 } + + ::can_ok( 'WantsSugar', 'has' ); + ::can_ok( 'WantsSugar', 'with' ); + ::can_ok( 'WantsSugar', 'wrapped1' ); + ::can_ok( 'WantsSugar', 'foo' ); + ::is( wrapped1(), 'WantsSugar called wrapped1', + 'wrapped1 identifies the caller correctly' ); + + MooseX::Sugar->unimport(); +} + +{ + ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' ); + ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' ); + can_ok( 'WantsSugar', 'foo' ); +} + +{ + package MooseX::MoreSugar; + + use Moose (); + + sub wrapped2 { + my $caller = shift->name; + return $caller . ' called wrapped2'; + } + + sub as_is1 { + return 'as_is1'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['wrapped2'], + as_is => ['as_is1'], + also => 'MooseX::Sugar', + ); +} + +{ + package WantsMoreSugar; + + MooseX::MoreSugar->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMoreSugar', 'has' ); + ::can_ok( 'WantsMoreSugar', 'with' ); + ::can_ok( 'WantsMoreSugar', 'wrapped1' ); + ::can_ok( 'WantsMoreSugar', 'wrapped2' ); + ::can_ok( 'WantsMoreSugar', 'as_is1' ); + ::can_ok( 'WantsMoreSugar', 'foo' ); + ::is( wrapped1(), 'WantsMoreSugar called wrapped1', + 'wrapped1 identifies the caller correctly' ); + ::is( wrapped2(), 'WantsMoreSugar called wrapped2', + 'wrapped2 identifies the caller correctly' ); + ::is( as_is1(), 'as_is1', + 'as_is1 works as expected' ); + + MooseX::MoreSugar->unimport(); +} + +{ + ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' ); + ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' ); + ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' ); + ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' ); + ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' ); + can_ok( 'WantsMoreSugar', 'foo' ); +} + +{ + package My::Metaclass; + use Moose; + BEGIN { extends 'Moose::Meta::Class' } + + package My::Object; + use Moose; + BEGIN { extends 'Moose::Object' } + + package HasInitMeta; + + use Moose (); + + sub init_meta { + shift; + return Moose->init_meta( @_, + metaclass => 'My::Metaclass', + base_class => 'My::Object', + ); + } + + Moose::Exporter->setup_import_methods( also => 'Moose' ); +} + +{ + package NewMeta; + + HasInitMeta->import(); +} + +{ + isa_ok( NewMeta->meta(), 'My::Metaclass' ); + isa_ok( NewMeta->new(), 'My::Object' ); +} + +{ + package MooseX::CircularAlso; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => [ 'Moose', 'MooseX::CircularAlso' ], + ); + }, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, + 'a circular reference in also dies with an error' + ); +} + +{ + package MooseX::NoAlso; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => ['NoSuchThing'], + ); + }, + qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?) at /, + 'a package which does not use Moose::Exporter in also dies with an error' + ); +} + +{ + package MooseX::NotExporter; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => ['Moose::Meta::Method'], + ); + }, + qr/\QPackage in also (Moose::Meta::Method) does not seem to use Moose::Exporter at /, + 'a package which does not use Moose::Exporter in also dies with an error' + ); +} + +{ + package MooseX::OverridingSugar; + + use Moose (); + + sub has { + my $caller = shift->name; + return $caller . ' called has'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['has'], + also => 'Moose', + ); +} + +{ + package WantsOverridingSugar; + + MooseX::OverridingSugar->import(); + + ::can_ok( 'WantsOverridingSugar', 'has' ); + ::can_ok( 'WantsOverridingSugar', 'with' ); + ::is( has('foo'), 'WantsOverridingSugar called has', + 'has from MooseX::OverridingSugar is called, not has from Moose' ); + + MooseX::OverridingSugar->unimport(); +} + +{ + ok( ! WantsOverridingSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsOverridingSugar->can('with'), 'WantsSugar::with() has been cleaned' ); +} + +{ + package MooseX::OverridingSugar::PassThru; + + sub with { + my $caller = shift->name; + return $caller . ' called with'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['with'], + also => 'MooseX::OverridingSugar', + ); +} + +{ + + package WantsOverridingSugar::PassThru; + + MooseX::OverridingSugar::PassThru->import(); + + ::can_ok( 'WantsOverridingSugar::PassThru', 'has' ); + ::can_ok( 'WantsOverridingSugar::PassThru', 'with' ); + ::is( + has('foo'), + 'WantsOverridingSugar::PassThru called has', + 'has from MooseX::OverridingSugar is called, not has from Moose' + ); + + ::is( + with('foo'), + 'WantsOverridingSugar::PassThru called with', + 'with from MooseX::OverridingSugar::PassThru is called, not has from Moose' + ); + + + MooseX::OverridingSugar::PassThru->unimport(); +} + +{ + ok( ! WantsOverridingSugar::PassThru->can('has'), 'WantsOverridingSugar::PassThru::has() has been cleaned' ); + ok( ! WantsOverridingSugar::PassThru->can('with'), 'WantsOverridingSugar::PassThru::with() has been cleaned' ); +} + +{ + + package NonExistentExport; + + use Moose (); + + ::stderr_like { + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => ['does_not_exist'], + ); + } qr/^Trying to export undefined sub NonExistentExport::does_not_exist/, + "warns when a non-existent method is requested to be exported"; +} + +{ + package WantsNonExistentExport; + + NonExistentExport->import; + + ::ok(!__PACKAGE__->can('does_not_exist'), + "undefined subs do not get exported"); +} + +{ + package AllOptions; + use Moose (); + use Moose::Deprecated -api_version => '0.88'; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => [ 'with_meta1', 'with_meta2' ], + with_caller => [ 'with_caller1', 'with_caller2' ], + as_is => ['as_is1', \&Foreign::Class::as_is2, 'Foreign::Class::as_is3'], + ); + + sub with_caller1 { + return @_; + } + + sub with_caller2 (&) { + return @_; + } + + sub as_is1 {2} + + sub Foreign::Class::as_is2 { return 'as_is2' } + sub Foreign::Class::as_is3 { return 'as_is3' } + + sub with_meta1 { + return @_; + } + + sub with_meta2 (&) { + return @_; + } +} + +{ + package UseAllOptions; + + AllOptions->import(); +} + +{ + can_ok( 'UseAllOptions', $_ ) + for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 as_is2 as_is3 ); + + { + my ( $caller, $arg1 ) = UseAllOptions::with_caller1(42); + is( $caller, 'UseAllOptions', 'with_caller wrapped sub gets the right caller' ); + is( $arg1, 42, 'with_caller wrapped sub returns argument it was passed' ); + } + + { + my ( $meta, $arg1 ) = UseAllOptions::with_meta1(42); + isa_ok( $meta, 'Moose::Meta::Class', 'with_meta first argument' ); + is( $arg1, 42, 'with_meta1 returns argument it was passed' ); + } + + is( + prototype( UseAllOptions->can('with_caller2') ), + prototype( AllOptions->can('with_caller2') ), + 'using correct prototype on with_meta function' + ); + + is( + prototype( UseAllOptions->can('with_meta2') ), + prototype( AllOptions->can('with_meta2') ), + 'using correct prototype on with_meta function' + ); +} + +{ + package UseAllOptions; + AllOptions->unimport(); +} + +{ + ok( ! UseAllOptions->can($_), "UseAllOptions::$_ has been unimported" ) + for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 as_is2 as_is3 ); +} + +{ + package InitMetaError; + use Moose::Exporter; + use Moose (); + Moose::Exporter->setup_import_methods(also => ['Moose']); + sub init_meta { + my $package = shift; + my %options = @_; + Moose->init_meta(%options, metaclass => 'Not::Loaded'); + } +} + +{ + package InitMetaError::Role; + use Moose::Exporter; + use Moose::Role (); + Moose::Exporter->setup_import_methods(also => ['Moose::Role']); + sub init_meta { + my $package = shift; + my %options = @_; + Moose::Role->init_meta(%options, metaclass => 'Not::Loaded'); + } +} + +{ + package WantsInvalidMetaclass; + ::like( + ::exception { InitMetaError->import }, + qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, + "error when wanting a nonexistent metaclass" + ); +} + +{ + package WantsInvalidMetaclass::Role; + ::like( + ::exception { InitMetaError::Role->import }, + qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, + "error when wanting a nonexistent metaclass" + ); +} + +{ + my @init_metas_called; + + BEGIN { + package MultiLevelExporter1; + use Moose::Exporter; + + sub foo { 1 } + sub bar { 1 } + sub baz { 1 } + sub quux { 1 } + + Moose::Exporter->setup_import_methods( + with_meta => [qw(foo bar baz quux)], + ); + + sub init_meta { + push @init_metas_called, 1; + } + + $INC{'MultiLevelExporter1.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter2; + use Moose::Exporter; + + sub bar { 2 } + sub baz { 2 } + sub quux { 2 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter1'], + with_meta => [qw(bar baz quux)], + ); + + sub init_meta { + push @init_metas_called, 2; + } + + $INC{'MultiLevelExporter2.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter3; + use Moose::Exporter; + + sub baz { 3 } + sub quux { 3 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter2'], + with_meta => [qw(baz quux)], + ); + + sub init_meta { + push @init_metas_called, 3; + } + + $INC{'MultiLevelExporter3.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter4; + use Moose::Exporter; + + sub quux { 4 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter3'], + with_meta => [qw(quux)], + ); + + sub init_meta { + push @init_metas_called, 4; + } + + $INC{'MultiLevelExporter4.pm'} = __FILE__; + } + + BEGIN { @init_metas_called = () } + { + package UsesMulti1; + use Moose; + use MultiLevelExporter1; + ::is(foo(), 1); + ::is(bar(), 1); + ::is(baz(), 1); + ::is(quux(), 1); + } + use Data::Dumper; + BEGIN { is_deeply(\@init_metas_called, [ 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti2; + use Moose; + use MultiLevelExporter2; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 2); + ::is(quux(), 2); + } + BEGIN { is_deeply(\@init_metas_called, [ 2, 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti3; + use Moose; + use MultiLevelExporter3; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 3); + ::is(quux(), 3); + } + BEGIN { is_deeply(\@init_metas_called, [ 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti4; + use Moose; + use MultiLevelExporter4; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 3); + ::is(quux(), 4); + } + BEGIN { is_deeply(\@init_metas_called, [ 4, 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } +} + +# Using "also => [ 'MooseX::UsesAlsoMoose', 'MooseX::SomethingElse' ]" should +# continue to work. The init_meta order needs to be MooseX::CurrentExporter, +# MooseX::UsesAlsoMoose, Moose, MooseX::SomethingElse. This is a pretty ugly +# and messed up use case, but necessary until we come up with a better way to +# do it. + +{ + my @init_metas_called; + + BEGIN { + package AlsoTest::Role1; + use Moose::Role; + } + + BEGIN { + package AlsoTest1; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => [ 'Moose' ], + ); + + sub init_meta { + shift; + my %opts = @_; + ::ok(!Class::MOP::class_of($opts{for_class})); + push @init_metas_called, 1; + } + + $INC{'AlsoTest1.pm'} = __FILE__; + } + + BEGIN { + package AlsoTest2; + use Moose::Exporter; + use Moose::Util::MetaRole (); + + Moose::Exporter->setup_import_methods; + + sub init_meta { + shift; + my %opts = @_; + ::ok(Class::MOP::class_of($opts{for_class})); + Moose::Util::MetaRole::apply_metaroles( + for => $opts{for_class}, + class_metaroles => { + class => ['AlsoTest::Role1'], + }, + ); + push @init_metas_called, 2; + } + + $INC{'AlsoTest2.pm'} = __FILE__; + } + + BEGIN { + package AlsoTest3; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => [ 'AlsoTest1', 'AlsoTest2' ], + ); + + sub init_meta { + shift; + my %opts = @_; + ::ok(!Class::MOP::class_of($opts{for_class})); + push @init_metas_called, 3; + } + + $INC{'AlsoTest3.pm'} = __FILE__; + } + + BEGIN { @init_metas_called = () } + { + package UsesAlsoTest3; + use AlsoTest3; + } + use Data::Dumper; + BEGIN { + is_deeply(\@init_metas_called, [ 3, 1, 2 ]) + || diag(Dumper(\@init_metas_called)); + isa_ok(Class::MOP::class_of('UsesAlsoTest3'), 'Moose::Meta::Class'); + does_ok(Class::MOP::class_of('UsesAlsoTest3'), 'AlsoTest::Role1'); + } + +} + +done_testing; diff --git a/t/metaclasses/moose_exporter_trait_aliases.t b/t/metaclasses/moose_exporter_trait_aliases.t new file mode 100644 index 0000000..633674d --- /dev/null +++ b/t/metaclasses/moose_exporter_trait_aliases.t @@ -0,0 +1,88 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Attribute::Trait::Awesome; + use Moose::Role; +} + +BEGIN { + package Awesome::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + trait_aliases => ['Attribute::Trait::Awesome'], + ); +} + +{ + package Awesome; + use Moose; + BEGIN { Awesome::Exporter->import } + + has foo => ( + traits => [Awesome], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + no Moose; + BEGIN { Awesome::Exporter->unimport } + + my $val = eval "Awesome"; + ::like($@, qr/Bareword "Awesome" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); +} + +BEGIN { + package Awesome2::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + trait_aliases => [ + [ 'Attribute::Trait::Awesome' => 'Awesome2' ], + ], + ); +} + +{ + package Awesome2; + use Moose; + BEGIN { Awesome2::Exporter->import } + + has foo => ( + traits => [Awesome2], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + BEGIN { Awesome2::Exporter->unimport } + + my $val = eval "Awesome2"; + ::like($@, qr/Bareword "Awesome2" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); +} + +{ + package Awesome2::Rename; + use Moose; + BEGIN { Awesome2::Exporter->import(Awesome2 => { -as => 'emosewA' }) } + + has foo => ( + traits => [emosewA], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + BEGIN { Awesome2::Exporter->unimport } + + { our $TODO; local $TODO = "unimporting renamed subs currently doesn't work"; + my $val = eval "emosewA"; + ::like($@, qr/Bareword "emosewA" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); + } +} + +done_testing; diff --git a/t/metaclasses/moose_for_meta.t b/t/metaclasses/moose_for_meta.t new file mode 100644 index 0000000..8956380 --- /dev/null +++ b/t/metaclasses/moose_for_meta.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates the ability to extend +Moose meta-level classes using Moose itself. + +=cut + +{ + package My::Meta::Class; + use Moose; + + extends 'Moose::Meta::Class'; + + around 'create_anon_class' => sub { + my $next = shift; + my ($self, %options) = @_; + $options{superclasses} = [ 'Moose::Object' ] + unless exists $options{superclasses}; + $next->($self, %options); + }; +} + +my $anon = My::Meta::Class->create_anon_class(); +isa_ok($anon, 'My::Meta::Class'); +isa_ok($anon, 'Moose::Meta::Class'); +isa_ok($anon, 'Class::MOP::Class'); + +is_deeply( + [ $anon->superclasses ], + [ 'Moose::Object' ], + '... got the default superclasses'); + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my ($self, $name, %options) = @_; + $options{is} = 'ro' + unless exists $options{is}; + $next->($self, $name, %options); + }; +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo'); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Moose::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok($attr->has_reader, '... the attribute has a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok(!$attr->has_accessor, '... the attribute does not have an accessor (as expected)'); +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo', (is => 'rw')); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Moose::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_reader, '... the attribute does not have a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok($attr->has_accessor, '... the attribute does have an accessor (as expected)'); +} + +done_testing; diff --git a/t/metaclasses/moose_nonmoose_metatrait_init_order.t b/t/metaclasses/moose_nonmoose_metatrait_init_order.t new file mode 100644 index 0000000..56f7b36 --- /dev/null +++ b/t/metaclasses/moose_nonmoose_metatrait_init_order.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +{ + package My::Role; + use Moose::Role; +} +{ + package SomeClass; + use Moose -traits => 'My::Role'; +} +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; +} +{ + package SubSubClassUseBase; + use parent -norequire => 'SubClassUseBase'; +} + +use Test::More; +use Moose::Util qw/find_meta does_role/; + +my $subsubclass_meta = Moose->init_meta( for_class => 'SubSubClassUseBase' ); +ok does_role($subsubclass_meta, 'My::Role'), + 'SubSubClass metaclass does role from grandparent metaclass'; +my $subclass_meta = find_meta('SubClassUseBase'); +ok does_role($subclass_meta, 'My::Role'), + 'SubClass metaclass does role from parent metaclass'; + +done_testing; diff --git a/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t b/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t new file mode 100644 index 0000000..31df803 --- /dev/null +++ b/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +{ + package ParentClass; + use Moose; +} +{ + package SomeClass; + use parent -norequire => 'ParentClass'; +} +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; + use Moose; +} + +use Test::More; +use Test::Fatal; + +is( exception { + Moose->init_meta(for_class => 'SomeClass'); +}, undef, 'Moose class => use parent => Moose Class, then Moose->init_meta on middle class ok' ); + +done_testing; diff --git a/t/metaclasses/moose_w_metaclass.t b/t/metaclasses/moose_w_metaclass.t new file mode 100644 index 0000000..41f9de0 --- /dev/null +++ b/t/metaclasses/moose_w_metaclass.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates that Moose will respect +a metaclass previously set with the metaclass +pragma. + +It also checks an error condition where that +metaclass must be a Moose::Meta::Class subclass +in order to work. + +=cut + + +{ + package Foo::Meta; + use strict; + use warnings; + + use parent 'Moose::Meta::Class'; + + package Foo; + use strict; + use warnings; + use metaclass 'Foo::Meta'; + ::use_ok('Moose'); +} + +isa_ok(Foo->meta, 'Foo::Meta'); + +{ + package Bar::Meta; + use strict; + use warnings; + + use parent 'Class::MOP::Class'; + + package Bar; + use strict; + use warnings; + use metaclass 'Bar::Meta'; + eval 'use Moose;'; + ::ok($@, '... could not load moose without correct metaclass'); + ::like($@, + qr/^Bar already has a metaclass, but it does not inherit Moose::Meta::Class/, + '... got the right error too'); +} + +done_testing; diff --git a/t/metaclasses/new_metaclass.t b/t/metaclasses/new_metaclass.t new file mode 100644 index 0000000..7d439b1 --- /dev/null +++ b/t/metaclasses/new_metaclass.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; + +do { + package My::Meta::Class; + use Moose; + BEGIN { extends 'Moose::Meta::Class' }; + + package Moose::Meta::Class::Custom::MyMetaClass; + sub register_implementation { 'My::Meta::Class' } +}; + +do { + package My::Class; + use Moose -metaclass => 'My::Meta::Class'; +}; + +do { + package My::Class::Aliased; + use Moose -metaclass => 'MyMetaClass'; +}; + +is(My::Class->meta->meta->name, 'My::Meta::Class'); +is(My::Class::Aliased->meta->meta->name, 'My::Meta::Class'); + +done_testing; diff --git a/t/metaclasses/new_object_BUILD.t b/t/metaclasses/new_object_BUILD.t new file mode 100644 index 0000000..22b37c8 --- /dev/null +++ b/t/metaclasses/new_object_BUILD.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +my $called; +{ + package Foo; + use Moose; + + sub BUILD { $called++ } +} + +Foo->new; +is($called, 1, "BUILD called from ->new"); +$called = 0; +Foo->meta->new_object; +is($called, 1, "BUILD called from ->meta->new_object"); + +done_testing; diff --git a/t/metaclasses/overloading.t b/t/metaclasses/overloading.t new file mode 100644 index 0000000..31cd907 --- /dev/null +++ b/t/metaclasses/overloading.t @@ -0,0 +1,480 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Sub::Name qw( subname ); + +my $quote = qr/['`"]/; + +{ + package Foo; + use Moose; +} + +{ + my $meta = Foo->meta; + + subtest( + 'Foo class (not overloaded)', + sub { + ok( !$meta->is_overloaded, 'is not overloaded' ); + + ok( + !$meta->has_overloaded_operator('+'), + 'has no + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], [], + '->get_overload_list returns an empty list' + ); + + is_deeply( + [ $meta->get_all_overloaded_operators ], [], + '->get_all_overloaded_operators return an empty list' + ); + + is( + $meta->get_overloaded_operator('+'), undef, + 'get_overloaded_operator(+) returns undef' + ); + is( + $meta->get_overloaded_operator('-'), undef, + 'get_overloaded_operator(-) returns undef' + ); + } + ); +} + +my $plus = 0; +my $plus_impl; + +BEGIN { + $plus_impl = sub { $plus = 1; 42 } +} +{ + package Foo::Overloaded; + use Moose; + use overload '+' => $plus_impl; +} + +{ + my $meta = Foo::Overloaded->meta; + + subtest( + 'Foo::Overload class (overloaded with coderef)', + sub { + ok( $meta->is_overloaded, 'is overloaded' ); + + ok( + $meta->has_overloaded_operator('+'), + 'has + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], ['+'], + '->get_overload_list returns (+) ' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 operator' + ); + my $plus_overload = $overloads[0]; + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( $plus_overload->operator, '+', 'operator for overload is +' ); + is( + $plus_overload->coderef, $plus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $plus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $plus_overload->coderef_name, '__ANON__', + 'coderef name for overload is __ANON__' + ); + ok( + $plus_overload->is_anonymous, + 'overload is anonymous' + ); + ok( + !$plus_overload->has_method_name, + 'overload has no method name' + ); + ok( + !$plus_overload->has_method, + 'overload has no method' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + my $plus_overload2 = $meta->get_overloaded_operator('+'); + is( + $plus_overload2, $plus_overload, + '->get_overloaded_operator(+) returns the same operator on each call' + ); + + is( $plus, 0, '+ overloading has not been called' ); + is( + Foo::Overloaded->new + Foo::Overloaded->new, 42, + '+ overloading returns 42' + ); + is( $plus, 1, '+ overloading was called once' ); + + ok( + $plus_overload->_is_equal_to($plus_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $plus_overload3 = Class::MOP::Overload->new( + operator => '+', + coderef => $plus_impl, + coderef_package => 'main', + coderef_name => '__ANON__', + ); + + ok( + $plus_overload->_is_equal_to($plus_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + my $minus = 0; + my $minus_impl + = subname( 'overload_minus', sub { $minus = 1; -42 } ); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails' + ); + + $meta->add_overloaded_operator( '-' => $minus_impl ); + + ok( + $meta->has_overloaded_operator('-'), + 'has - operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '+', '-' ], + '->get_overload_list returns (+, -)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $minus_overload = $meta->get_overloaded_operator('-'); + isa_ok( + $minus_overload, 'Class::MOP::Overload', + 'object for - overloading' + ); + is( + $minus_overload->operator, '-', + 'operator for overload is -' + ); + is( + $minus_overload->coderef, $minus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $minus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $minus_overload->coderef_name, 'overload_minus', + 'coderef name for overload is overload_minus' + ); + ok( + !$minus_overload->is_anonymous, + 'overload is not anonymous' + ); + is( + $minus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $minus, 0, '- overloading has not been called' ); + is( + Foo::Overloaded->new - Foo::Overloaded->new, -42, + '- overloading returns -42' + ); + is( $minus, 1, '+- overloading was called once' ); + + ok( + !$plus_overload->_is_equal_to($minus_overload), + '_is_equal_to returns false for objects with different properties' + ); + + $meta->remove_overloaded_operator('-'); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +my $times = 0; +my $divided = 0; +{ + package Foo::OverloadWithMethod; + use Moose; + use overload '*' => 'times'; + + sub times { $times = 1; 'times' } + sub divided { $divided = 1; 'divided' } +} + +{ + my $meta = Foo::OverloadWithMethod->meta; + + subtest( + 'Foo::OverloadWithMethod (overloaded via method)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('*'), + 'overloads *' + ); + ok( + !$meta->has_overloaded_operator('/'), + 'does not overload /' + ); + + is_deeply( + [ $meta->get_overload_list ], ['*'], + '->get_overload_list returns (*)' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 item' + ); + my $times_overload = $overloads[0]; + isa_ok( + $times_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $times_overload->operator, '*', + 'operator for overload is +' + ); + ok( + $times_overload->has_method_name, + 'overload has a method name' + ); + is( + $times_overload->method_name, 'times', + q{method name is 'times'} + ); + ok( + !$times_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$times_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$times_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$times_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + $times_overload->has_method, + 'overload has a method' + ); + is( + $times_overload->method, $meta->get_method('times'), + '->method returns method object for times method' + ); + is( + $times_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $times, 0, '* overloading has not been called' ); + is( + Foo::OverloadWithMethod->new * Foo::OverloadWithMethod->new, + 'times', + q{* overloading returns 'times'} + ); + is( $times, 1, '* overloading was called once' ); + + my $times_overload2 = $meta->get_overloaded_operator('*'); + + ok( + $times_overload->_is_equal_to($times_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $times_overload3 = Class::MOP::Overload->new( + operator => '*', + method_name => 'times', + ); + + ok( + $times_overload->_is_equal_to($times_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails' + ); + + $meta->add_overloaded_operator( '/' => 'divided' ); + + ok( + $meta->has_overloaded_operator('/'), + 'has / operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '*', '/' ], + '->get_overload_list returns (*, /)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $divided_overload = $meta->get_overloaded_operator('/'); + isa_ok( + $divided_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $divided_overload->operator, '/', + 'operator for overload is /' + ); + is( + $divided_overload->method_name, 'divided', + q{method name is 'divided'} + ); + is( + $divided_overload->method, $meta->get_method('divided'), + '->method returns method object for divided method' + ); + is( + $divided_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + $meta->remove_overloaded_operator('/'); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +{ + package Foo::UnimplementedOverload; + use Moose; + use overload '+' => 'plus'; +} + +{ + my $meta = Foo::UnimplementedOverload->meta; + + subtest( + 'Foo::UnimplementedOverload (overloaded via method that does not exist)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('+'), + 'overloads +' + ); + + my $plus_overload = $meta->get_overloaded_operator('+'); + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $plus_overload->operator, '+', + 'operator for overload is +' + ); + ok( + $plus_overload->has_method_name, + 'overload has a method name' + ); + is( + $plus_overload->method_name, 'plus', + q{method name is 'plus'} + ); + ok( + !$plus_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$plus_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$plus_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$plus_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + !$plus_overload->has_method, + 'overload has no method object' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + } + ); +} + +done_testing; diff --git a/t/metaclasses/reinitialize.t b/t/metaclasses/reinitialize.t new file mode 100644 index 0000000..2e6020b --- /dev/null +++ b/t/metaclasses/reinitialize.t @@ -0,0 +1,320 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use Test::Fatal; + +sub check_meta_sanity { + my ($meta, $class) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + isa_ok($meta, 'Moose::Meta::Class'); + is($meta->name, $class); + ok($meta->has_method('foo')); + isa_ok($meta->get_method('foo'), 'Moose::Meta::Method'); + ok($meta->has_attribute('bar')); + isa_ok($meta->get_attribute('bar'), 'Moose::Meta::Attribute'); + + if ( $meta->name eq 'Foo' ) { + ok($meta->does_role('Role1'), 'does Role1'); + ok($meta->does_role('Role2'), 'does Role2'); + + is_deeply( + [ + map { [ $_->role->name, $_->class->name ] } + sort { $a->role->name cmp $b->role->name } + $meta->role_applications + ], + [ + [ 'Role1|Role2', 'Foo' ], + ], + 'role applications for Role1 and Role2' + ); + } +} + +{ + package Role1; + use Moose::Role; +} + +{ + package Role2; + use Moose::Role; +} + +{ + package Foo; + use Moose; + sub foo {} + with 'Role1', 'Role2'; + has bar => (is => 'ro'); +} + +check_meta_sanity(Foo->meta, 'Foo'); + +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); + +{ + package Foo::Role::Method; + use Moose::Role; + + has foo => (is => 'rw'); +} + +{ + package Foo::Role::Attribute; + use Moose::Role; + has oof => (is => 'rw'); +} + +Moose::Util::MetaRole::apply_metaroles( + for => 'Foo', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Foo->meta, 'Foo'); +does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); +does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +Foo->meta->get_method('foo')->foo('TEST'); +Foo->meta->get_attribute('bar')->oof('TSET'); +is(Foo->meta->get_method('foo')->foo, 'TEST'); +is(Foo->meta->get_attribute('bar')->oof, 'TSET'); +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); +is(Foo->meta->get_method('foo')->foo, 'TEST'); +is(Foo->meta->get_attribute('bar')->oof, 'TSET'); + +{ + package Bar::Role::Method; + use Moose::Role; +} + +{ + package Bar::Role::Attribute; + use Moose::Role; +} + +{ + package Bar; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => 'Bar', + class_metaroles => { + method => ['Bar::Role::Method'], + attribute => ['Bar::Role::Attribute'], + }, + ); + sub foo {} + has bar => (is => 'ro'); +} + +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); + +Moose::Meta::Class->reinitialize('Bar'); +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); +ok(!Moose::Util::does_role(Bar->meta->get_method('foo'), 'Foo::Role::Method')); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute')); + +Moose::Util::MetaRole::apply_metaroles( + for => 'Bar', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); +does_ok(Bar->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +{ + package Bar::Meta::Method; + use Moose; + BEGIN { extends 'Moose::Meta::Method' }; +} + +{ + package Bar::Meta::Attribute; + use Moose; + BEGIN { extends 'Moose::Meta::Attribute' }; +} + +like( exception { + Moose::Meta::Class->reinitialize( + 'Bar', + method_metaclass => 'Bar::Meta::Method', + attribute_metaclass => 'Bar::Meta::Attribute', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Baz::Meta::Class; + use Moose; + BEGIN { extends 'Moose::Meta::Class' }; + + sub initialize { + my $self = shift; + return $self->SUPER::initialize( + @_, + method_metaclass => 'Bar::Meta::Method', + attribute_metaclass => 'Bar::Meta::Attribute' + ); + } +} + +{ + package Baz; + use Moose -metaclass => 'Baz::Meta::Class'; + sub foo {} + has bar => (is => 'ro'); +} + +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +Moose::Meta::Class->reinitialize('Baz'); +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); + +Moose::Util::MetaRole::apply_metaroles( + for => 'Baz', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +does_ok(Baz->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Baz->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +{ + package Baz::Meta::Method; + use Moose; + extends 'Moose::Meta::Method'; +} + +{ + package Baz::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; +} + +like( exception { + Moose::Meta::Class->reinitialize( + 'Baz', + method_metaclass => 'Baz::Meta::Method', + attribute_metaclass => 'Baz::Meta::Attribute', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Quux; + use Moose; + sub foo { } + before foo => sub { }; + has bar => (is => 'ro'); + sub DEMOLISH { } + __PACKAGE__->meta->make_immutable; +} + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); + +Quux->meta->make_mutable; +Moose::Meta::Class->reinitialize('Quux'); +Quux->meta->make_immutable; + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); + +Quux->meta->make_mutable; +Moose::Util::MetaRole::apply_metaroles( + for => 'Quux', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +Quux->meta->make_immutable; + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +{ local $TODO = "constructor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('new'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +{ local $TODO = "meta methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('meta'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +{ local $TODO = "modified methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('foo'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +{ local $TODO = "accessor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('bar'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +{ local $TODO = "destructor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('DESTROY'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); +does_ok(Quux->meta->get_method('DEMOLISH'), 'Foo::Role::Method'); + +{ + package Role3; + use Moose::Role; + with 'Role1', 'Role2'; +} + +ok( Role3->meta->does_role('Role1'), 'Role3 does Role1' ); +ok( Role3->meta->does_role('Role2'), 'Role3 does Role2' ); + +Moose::Meta::Role->reinitialize('Role3'); + +ok( Role3->meta->does_role('Role1'), 'Role3 does Role1 after reinitialize' ); +ok( Role3->meta->does_role('Role2'), 'Role3 does Role2 after reinitialize' ); + +done_testing; diff --git a/t/metaclasses/use_base_of_moose.t b/t/metaclasses/use_base_of_moose.t new file mode 100644 index 0000000..fdcd601 --- /dev/null +++ b/t/metaclasses/use_base_of_moose.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; + +{ + package NoOpTrait; + use Moose::Role; +} + +{ + package Parent; + use Moose -traits => 'NoOpTrait'; + + has attr => ( + is => 'rw', + isa => 'Str', + ); +} + +{ + package Child; + use parent -norequire => 'Parent'; +} + +is(Child->meta->name, 'Child', "correct metaclass name"); + +my $child = Child->new(attr => "ibute"); +ok($child, "constructor works"); + +is($child->attr, "ibute", "getter inherited properly"); + +$child->attr("ition"); +is($child->attr, "ition", "setter inherited properly"); + +done_testing; diff --git a/t/moose_util/apply_roles.t b/t/moose_util/apply_roles.t new file mode 100644 index 0000000..48edea7 --- /dev/null +++ b/t/moose_util/apply_roles.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Util qw( apply_all_roles ); + +{ + package Role::Foo; + use Moose::Role; +} + +{ + package Role::Bar; + use Moose::Role; +} + +{ + package Role::Baz; + use Moose::Role; +} + +{ + package Class::A; + use Moose; +} + +{ + package Class::B; + use Moose; +} + +{ + package Class::C; + use Moose; +} + +{ + package Class::D; + use Moose; +} + +{ + package Class::E; + use Moose; +} + +my @roles = qw( Role::Foo Role::Bar Role::Baz ); +apply_all_roles( 'Class::A', @roles ); +ok( Class::A->meta->does_role($_), "Class::A does $_" ) for @roles; + +apply_all_roles( 'Class::B', map { $_->meta } @roles ); +ok( Class::A->meta->does_role($_), + "Class::B does $_ (applied with meta role object)" ) + for @roles; + +@roles = qw( Role::Foo ); +apply_all_roles( 'Class::C', @roles ); +ok( Class::A->meta->does_role($_), "Class::C does $_" ) for @roles; + +apply_all_roles( 'Class::D', map { $_->meta } @roles ); +ok( Class::A->meta->does_role($_), + "Class::D does $_ (applied with meta role object)" ) + for @roles; + +@roles = qw( Role::Foo Role::Bar ), Role::Baz->meta; +apply_all_roles( 'Class::E', @roles ); +ok( Class::A->meta->does_role($_), + "Class::E does $_ (mix of names and meta role object)" ) + for @roles; + +done_testing; diff --git a/t/moose_util/create_alias.t b/t/moose_util/create_alias.t new file mode 100644 index 0000000..1f97104 --- /dev/null +++ b/t/moose_util/create_alias.t @@ -0,0 +1,102 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose qw(does_ok); + +BEGIN { + package Foo::Meta::Role; + use Moose::Role; + Moose::Util::meta_class_alias + FooRole => 'Foo::Meta::Role'; + + package Foo::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; + with 'Foo::Meta::Role'; + Moose::Util::meta_class_alias + FooClass => 'Foo::Meta::Class'; + + package Foo::Meta::Role::Attribute; + use Moose::Role; + Moose::Util::meta_attribute_alias + FooAttrRole => 'Foo::Meta::Role::Attribute'; + + package Foo::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; + with 'Foo::Meta::Role::Attribute'; + Moose::Util::meta_attribute_alias + FooAttrClass => 'Foo::Meta::Attribute'; + + package Bar::Meta::Role; + use Moose::Role; + Moose::Util::meta_class_alias 'BarRole'; + + package Bar::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; + with 'Bar::Meta::Role'; + Moose::Util::meta_class_alias 'BarClass'; + + package Bar::Meta::Role::Attribute; + use Moose::Role; + Moose::Util::meta_attribute_alias 'BarAttrRole'; + + package Bar::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; + with 'Bar::Meta::Role::Attribute'; + Moose::Util::meta_attribute_alias 'BarAttrClass'; +} + +package FooWithMetaClass; +use Moose -metaclass => 'FooClass'; + +has bar => ( + metaclass => 'FooAttrClass', + is => 'ro', +); + + +package FooWithMetaTrait; +use Moose -traits => 'FooRole'; + +has bar => ( + traits => [qw(FooAttrRole)], + is => 'ro', +); + +package BarWithMetaClass; +use Moose -metaclass => 'BarClass'; + +has bar => ( + metaclass => 'BarAttrClass', + is => 'ro', +); + + +package BarWithMetaTrait; +use Moose -traits => 'BarRole'; + +has bar => ( + traits => [qw(BarAttrRole)], + is => 'ro', +); + +package main; +my $fwmc_meta = FooWithMetaClass->meta; +my $fwmt_meta = FooWithMetaTrait->meta; +isa_ok($fwmc_meta, 'Foo::Meta::Class'); +isa_ok($fwmc_meta->get_attribute('bar'), 'Foo::Meta::Attribute'); +does_ok($fwmt_meta, 'Foo::Meta::Role'); +does_ok($fwmt_meta->get_attribute('bar'), 'Foo::Meta::Role::Attribute'); + +my $bwmc_meta = BarWithMetaClass->meta; +my $bwmt_meta = BarWithMetaTrait->meta; +isa_ok($bwmc_meta, 'Bar::Meta::Class'); +isa_ok($bwmc_meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +does_ok($bwmt_meta, 'Bar::Meta::Role'); +does_ok($bwmt_meta->get_attribute('bar'), 'Bar::Meta::Role::Attribute'); + +done_testing; diff --git a/t/moose_util/ensure_all_roles.t b/t/moose_util/ensure_all_roles.t new file mode 100644 index 0000000..9888bfb --- /dev/null +++ b/t/moose_util/ensure_all_roles.t @@ -0,0 +1,62 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util ':all'; + +{ + package Foo; + use Moose::Role; +} + +{ + package Bar; + use Moose::Role; +} + +{ + package Quux; + use Moose; +} + +is_deeply( + Quux->meta->roles, + [], + "no roles yet", +); + +Foo->meta->apply(Quux->meta); + +is_deeply( + Quux->meta->roles, + [ Foo->meta ], + "applied Foo", +); + +Foo->meta->apply(Quux->meta); +Bar->meta->apply(Quux->meta); +is_deeply( + Quux->meta->roles, + [ Foo->meta, Foo->meta, Bar->meta ], + "duplicated Foo", +); + +is(does_role('Quux', 'Foo'), 1, "Quux does Foo"); +is(does_role('Quux', 'Bar'), 1, "Quux does Bar"); +ensure_all_roles('Quux', qw(Foo Bar)); +is_deeply( + Quux->meta->roles, + [ Foo->meta, Foo->meta, Bar->meta ], + "unchanged, since all roles are already applied", +); + +my $obj = Quux->new; +ensure_all_roles($obj, qw(Foo Bar)); +is_deeply( + $obj->meta->roles, + [ Foo->meta, Foo->meta, Bar->meta ], + "unchanged, since all roles are already applied", +); + +done_testing; diff --git a/t/moose_util/method_mod_args.t b/t/moose_util/method_mod_args.t new file mode 100644 index 0000000..c4536d8 --- /dev/null +++ b/t/moose_util/method_mod_args.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose::Util qw( add_method_modifier ); + +my $COUNT = 0; +{ + package Foo; + use Moose; + + sub foo { } + sub bar { } +} + +is( exception { + add_method_modifier('Foo', 'before', [ ['foo', 'bar'], sub { $COUNT++ } ]); +}, undef, 'method modifier with an arrayref' ); + +isnt( exception { + add_method_modifier('Foo', 'before', [ {'foo' => 'bar'}, sub { $COUNT++ } ]); +}, undef, 'method modifier with a hashref' ); + +my $foo = Foo->new; +$foo->foo; +$foo->bar; +is($COUNT, 2, "checking that the modifiers were installed."); + + +done_testing; diff --git a/t/moose_util/moose_util.t b/t/moose_util/moose_util.t new file mode 100644 index 0000000..3203f74 --- /dev/null +++ b/t/moose_util/moose_util.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + use_ok('Moose::Util'); +} + +{ + package Moosey::Class; + use Moose; +} +{ + package Moosey::Role; + use Moose::Role; +} +{ + package Other; +} +{ + package Moosey::Composed; + use Moose; + with 'Moosey::Role'; +} + +use Moose::Util 'is_role'; + +{ + my $class = Moosey::Class->new; + my $composed = Moosey::Composed->new; + + ok(!is_role('Moosey::Class'), 'a moose class is not a role'); + ok(is_role('Moosey::Role'), 'a moose role is a role'); + ok(!is_role('Other'), 'something else is not a role'); + ok(!is_role('DoesNotExist'), 'non-existent namespace is not a role'); + ok(!is_role('Moosey::Composed'), 'a moose class that composes a role is not a role'); + + ok(!is_role($class), 'instantiated moose object is not a role'); + ok(!is_role($composed), 'instantiated moose object that does a role is not a role'); +} + +done_testing; diff --git a/t/moose_util/moose_util_does_role.t b/t/moose_util/moose_util_does_role.t new file mode 100644 index 0000000..916e3e7 --- /dev/null +++ b/t/moose_util/moose_util_does_role.t @@ -0,0 +1,92 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util ':all'; + +{ + package Foo; + + use Moose::Role; +} + +{ + package Bar; + + use Moose; + + with qw/Foo/; +} + +{ + package Baz; + + use Moose; +} + +{ + package Quux; + + use metaclass; +} + +{ + package Foo::Foo; + + use Moose::Role; + + with 'Foo'; +} + +{ + package DoesMethod; + use Moose; + + sub does { + my $self = shift; + my ($role) = @_; + return 1 if $role eq 'Something::Else'; + return $self->SUPER::does(@_); + } +} + +# Classes + +ok(does_role('Bar', 'Foo'), '... Bar does Foo'); + +ok(!does_role('Baz', 'Foo'), '... Baz doesnt do Foo'); + +# Objects + +my $bar = Bar->new; + +ok(does_role($bar, 'Foo'), '... $bar does Foo'); + +my $baz = Baz->new; + +ok(!does_role($baz, 'Foo'), '... $baz doesnt do Foo'); + +# Invalid values + +ok(!does_role(undef,'Foo'), '... undef doesnt do Foo'); + +ok(!does_role(1,'Foo'), '... 1 doesnt do Foo'); + +# non Moose metaclass + +ok(!does_role('Quux', 'Foo'), '... Quux doesnt do Foo (does not die tho)'); + +# overriding the does method works properly + +ok(does_role('DoesMethod', 'Something::Else'), '... can override the does method'); + +# Self + +ok(does_role('Foo', 'Foo'), '... Foo does do Foo'); + +# sub-Roles + +ok(does_role('Foo::Foo', 'Foo'), '... Foo::Foo does do Foo'); + +done_testing; diff --git a/t/moose_util/moose_util_search_class_by_role.t b/t/moose_util/moose_util_search_class_by_role.t new file mode 100644 index 0000000..3984757 --- /dev/null +++ b/t/moose_util/moose_util_search_class_by_role.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util ':all'; + +{ package SCBR::Role; + use Moose::Role; +} + +{ package SCBR::A; + use Moose; +} +is search_class_by_role('SCBR::A', 'SCBR::Role'), undef, '... not found role returns undef'; +is search_class_by_role('SCBR::A', SCBR::Role->meta), undef, '... not found role returns undef'; + +{ package SCBR::B; + use Moose; + extends 'SCBR::A'; + with 'SCBR::Role'; +} +is search_class_by_role('SCBR::B', 'SCBR::Role'), 'SCBR::B', '... class itself returned if it does role'; +is search_class_by_role('SCBR::B', SCBR::Role->meta), 'SCBR::B', '... class itself returned if it does role'; + +{ package SCBR::C; + use Moose; + extends 'SCBR::B'; +} +is search_class_by_role('SCBR::C', 'SCBR::Role'), 'SCBR::B', '... nearest class doing role returned'; +is search_class_by_role('SCBR::C', SCBR::Role->meta), 'SCBR::B', '... nearest class doing role returned'; + +{ package SCBR::D; + use Moose; + extends 'SCBR::C'; + with 'SCBR::Role'; +} +is search_class_by_role('SCBR::D', 'SCBR::Role'), 'SCBR::D', '... nearest class being direct class returned'; +is search_class_by_role('SCBR::D', SCBR::Role->meta), 'SCBR::D', '... nearest class being direct class returned'; + +done_testing; diff --git a/t/moose_util/resolve_alias.t b/t/moose_util/resolve_alias.t new file mode 100644 index 0000000..5b09b86 --- /dev/null +++ b/t/moose_util/resolve_alias.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util qw( resolve_metaclass_alias resolve_metatrait_alias ); + +use lib 't/lib'; + +# Doing each test twice is intended to make sure that the caching +# doesn't break name resolution. It doesn't actually test that +# anything is cached. +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo' ); + +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo second time' ); + +is( resolve_metaclass_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo)' ); + +is( resolve_metaclass_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo) a second time' ); + +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar' ); + +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar a second time' ); + +is( resolve_metaclass_alias( 'Attribute', 'Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar)' ); + +is( resolve_metaclass_alias( 'Attribute', 'Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar) a second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo)' ); + +is( resolve_metatrait_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo) a second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar a second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar)' ); + +is( resolve_metatrait_alias( 'Attribute', 'Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar) a second time' ); + +done_testing; diff --git a/t/moose_util/with_traits.t b/t/moose_util/with_traits.t new file mode 100644 index 0000000..6388eeb --- /dev/null +++ b/t/moose_util/with_traits.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +use Moose (); +use Moose::Util qw(with_traits); + +{ + package Foo; + use Moose; +} + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Foo::Role2; + use Moose::Role; +} + +{ + my $traited_class = with_traits('Foo', 'Foo::Role'); + ok($traited_class->meta->is_anon_class, "we get an anon class"); + isa_ok($traited_class, 'Foo'); + does_ok($traited_class, 'Foo::Role'); +} + +{ + my $traited_class = with_traits('Foo', 'Foo::Role', 'Foo::Role2'); + ok($traited_class->meta->is_anon_class, "we get an anon class"); + isa_ok($traited_class, 'Foo'); + does_ok($traited_class, 'Foo::Role'); + does_ok($traited_class, 'Foo::Role2'); +} + +{ + my $traited_class = with_traits('Foo'); + is($traited_class, 'Foo', "don't apply anything if we don't get any traits"); +} + +{ + my $traited_class = with_traits('Foo', 'Foo::Role'); + my $traited_class2 = with_traits('Foo', 'Foo::Role'); + is($traited_class, $traited_class2, "get the same class back when passing the same roles"); +} + +done_testing; diff --git a/t/native_traits/array_coerce.t b/t/native_traits/array_coerce.t new file mode 100644 index 0000000..301fd01 --- /dev/null +++ b/t/native_traits/array_coerce.t @@ -0,0 +1,235 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'UCArray', as 'ArrayRef[Str]', where { + !grep {/[a-z]/} @{$_}; + }; + + coerce 'UCArray', from 'ArrayRef[Str]', via { + [ map { uc $_ } @{$_} ]; + }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'UCArray', + coerce => 1, + handles => { + push_array => 'push', + set_array => 'set', + }, + ); + + our @TriggerArgs; + + has lazy => ( + traits => ['Array'], + is => 'rw', + isa => 'UCArray', + coerce => 1, + lazy => 1, + default => sub { ['a'] }, + handles => { + push_lazy => 'push', + set_lazy => 'set', + }, + trigger => sub { @TriggerArgs = @_ }, + clearer => 'clear_lazy', + ); +} + +my $foo = Foo->new; + +{ + $foo->array( [qw( A B C )] ); + + $foo->push_array('d'); + + is_deeply( + $foo->array, [qw( A B C D )], + 'push coerces the array' + ); + + $foo->set_array( 1 => 'x' ); + + is_deeply( + $foo->array, [qw( A X C D )], + 'set coerces the array' + ); +} + +{ + $foo->push_lazy('d'); + + is_deeply( + $foo->lazy, [qw( A D )], + 'push coerces the array - lazy' + ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [qw( A D )], ['A'] ], + 'trigger receives expected arguments' + ); + + $foo->set_lazy( 2 => 'f' ); + + is_deeply( + $foo->lazy, [qw( A D F )], + 'set coerces the array - lazy' + ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [qw( A D F )], [qw( A D )] ], + 'trigger receives expected arguments' + ); +} + +{ + package Thing; + use Moose; + + has thing => ( + is => 'ro', + isa => 'Int', + ); +} + +{ + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + class_type 'Thing'; + + coerce 'Thing' + => from 'Int' + => via { Thing->new( thing => $_ ) }; + + subtype 'ArrayRefOfThings' + => as 'ArrayRef[Thing]'; + + coerce 'ArrayRefOfThings' + => from 'ArrayRef[Int]' + => via { [ map { Thing->new( thing => $_ ) } @{$_} ] }; + + coerce 'ArrayRefOfThings' + => from 'Int' + => via { [ Thing->new( thing => $_ ) ] }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRefOfThings', + coerce => 1, + handles => { + push_array => 'push', + unshift_array => 'unshift', + set_array => 'set', + insert_array => 'insert', + }, + ); +} + +{ + my $bar = Bar->new( array => [ 1, 2, 3 ] ); + + $bar->push_array( 4, 5 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ 1, 2, 3, 4, 5 ], + 'push coerces new members' + ); + + $bar->unshift_array( -1, 0 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ -1, 0, 1, 2, 3, 4, 5 ], + 'unshift coerces new members' + ); + + $bar->set_array( 3 => 9 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ -1, 0, 1, 9, 3, 4, 5 ], + 'set coerces new members' + ); + + $bar->insert_array( 3 => 42 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ -1, 0, 1, 42, 9, 3, 4, 5 ], + 'insert coerces new members' + ); +} + +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'SmallArrayRef' + => as 'ArrayRef' + => where { @{$_} <= 2 }; + + coerce 'SmallArrayRef' + => from 'ArrayRef' + => via { [ @{$_}[ -2, -1 ] ] }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'SmallArrayRef', + coerce => 1, + handles => { + push_array => 'push', + set_array => 'set', + insert_array => 'insert', + }, + ); +} + +{ + my $baz = Baz->new( array => [ 1, 2, 3 ] ); + + is_deeply( + $baz->array, [ 2, 3 ], + 'coercion truncates array ref in constructor' + ); + + $baz->push_array(4); + + is_deeply( + $baz->array, [ 3, 4 ], + 'coercion truncates array ref on push' + ); + + $baz->insert_array( 1 => 5 ); + + is_deeply( + $baz->array, [ 5, 4 ], + 'coercion truncates array ref on insert' + ); + + $baz->push_array( 7, 8, 9 ); + + is_deeply( + $baz->array, [ 8, 9 ], + 'coercion truncates array ref on push' + ); +} + +done_testing; diff --git a/t/native_traits/array_from_role.t b/t/native_traits/array_from_role.t new file mode 100644 index 0000000..21d0a06 --- /dev/null +++ b/t/native_traits/array_from_role.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has 'bar' => ( is => 'rw' ); + + package Stuffed::Role; + use Moose::Role; + + has 'options' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Foo]', + ); + + package Bulkie::Role; + use Moose::Role; + + has 'stuff' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef', + handles => { + get_stuff => 'get', + } + ); + + package Stuff; + use Moose; + + ::is( ::exception { with 'Stuffed::Role'; + }, undef, '... this should work correctly' ); + + ::is( ::exception { with 'Bulkie::Role'; + }, undef, '... this should work correctly' ); +} + +done_testing; diff --git a/t/native_traits/array_subtypes.t b/t/native_traits/array_subtypes.t new file mode 100644 index 0000000..d85c8f6 --- /dev/null +++ b/t/native_traits/array_subtypes.t @@ -0,0 +1,264 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + use Moose::Util::TypeConstraints; + use List::Util qw(sum); + + subtype 'A1', as 'ArrayRef[Int]'; + subtype 'A2', as 'ArrayRef', where { @$_ < 2 }; + subtype 'A3', as 'ArrayRef[Int]', where { ( sum(@$_) || 0 ) < 5 }; + + subtype 'A5', as 'ArrayRef'; + coerce 'A5', from 'Str', via { [ $_ ] }; + + no Moose::Util::TypeConstraints; +} + +{ + package Foo; + use Moose; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + handles => { + push_array => 'push', + }, + ); + + has array_int => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef[Int]', + handles => { + push_array_int => 'push', + }, + ); + + has a1 => ( + traits => ['Array'], + is => 'rw', + isa => 'A1', + handles => { + push_a1 => 'push', + }, + ); + + has a2 => ( + traits => ['Array'], + is => 'rw', + isa => 'A2', + handles => { + push_a2 => 'push', + }, + ); + + has a3 => ( + traits => ['Array'], + is => 'rw', + isa => 'A3', + handles => { + push_a3 => 'push', + }, + ); + + has a4 => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => 'invalid', + clearer => '_clear_a4', + handles => { + get_a4 => 'get', + push_a4 => 'push', + accessor_a4 => 'accessor', + }, + ); + + has a5 => ( + traits => ['Array'], + is => 'rw', + isa => 'A5', + coerce => 1, + lazy => 1, + default => 'invalid', + clearer => '_clear_a5', + handles => { + get_a5 => 'get', + push_a5 => 'push', + accessor_a5 => 'accessor', + }, + ); +} + +my $foo = Foo->new; + +{ + $foo->array( [] ); + is_deeply( $foo->array, [], "array - correct contents" ); + + $foo->push_array('foo'); + is_deeply( $foo->array, ['foo'], "array - correct contents" ); +} + +{ + $foo->array_int( [] ); + is_deeply( $foo->array_int, [], "array_int - correct contents" ); + + isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" ); + is_deeply( $foo->array_int, [], "array_int - correct contents" ); + + $foo->push_array_int(1); + is_deeply( $foo->array_int, [1], "array_int - correct contents" ); +} + +{ + isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" ); + + $foo->a1( [] ); + is_deeply( $foo->a1, [], "a1 - correct contents" ); + + isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" ); + + is_deeply( $foo->a1, [], "a1 - correct contents" ); + + $foo->push_a1(1); + is_deeply( $foo->a1, [1], "a1 - correct contents" ); +} + +{ + isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" ); + + $foo->a2( [] ); + is_deeply( $foo->a2, [], "a2 - correct contents" ); + + $foo->push_a2('foo'); + is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); + + isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" ); + + is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); +} + +{ + isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" ); + + $foo->a3( [] ); + is_deeply( $foo->a3, [], "a3 - correct contents" ); + + isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" ); + + isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); + + is_deeply( $foo->a3, [], "a3 - correct contents" ); + + $foo->push_a3(1); + is_deeply( $foo->a3, [1], "a3 - correct contents" ); + + isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); + + is_deeply( $foo->a3, [1], "a3 - correct contents" ); + + $foo->push_a3(3); + is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" ); +} + +{ + my $expect + = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/; + + like( + exception { $foo->accessor_a4(0); }, + $expect, + 'invalid default is caught when trying to read via accessor' + ); + + like( + exception { $foo->accessor_a4( 0 => 42 ); }, + $expect, + 'invalid default is caught when trying to write via accessor' + ); + + like( + exception { $foo->push_a4(42); }, + $expect, + 'invalid default is caught when trying to push' + ); + + like( + exception { $foo->get_a4(42); }, + $expect, + 'invalid default is caught when trying to get' + ); +} + +{ + my $foo = Foo->new; + + is( + $foo->accessor_a5(0), 'invalid', + 'lazy default is coerced when trying to read via accessor' + ); + + $foo->_clear_a5; + + $foo->accessor_a5( 1 => 'thing' ); + + is_deeply( + $foo->a5, + [ 'invalid', 'thing' ], + 'lazy default is coerced when trying to write via accessor' + ); + + $foo->_clear_a5; + + $foo->push_a5('thing'); + + is_deeply( + $foo->a5, + [ 'invalid', 'thing' ], + 'lazy default is coerced when trying to push' + ); + + $foo->_clear_a5; + + is( + $foo->get_a5(0), 'invalid', + 'lazy default is coerced when trying to get' + ); +} + +{ + package Bar; + use Moose; +} + +{ + package HasArray; + use Moose; + + has objects => ( + isa => 'ArrayRef[Foo]', + traits => ['Array'], + handles => { + push_objects => 'push', + }, + ); +} + +{ + my $ha = HasArray->new(); + + like( + exception { $ha->push_objects( Bar->new ) }, + qr/\QValidation failed for 'Foo'/, + 'got expected error when pushing an object of the wrong class onto an array ref' + ); +} + +done_testing; diff --git a/t/native_traits/array_trigger.t b/t/native_traits/array_trigger.t new file mode 100644 index 0000000..419c303 --- /dev/null +++ b/t/native_traits/array_trigger.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + our @TriggerArgs; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + handles => { + push_array => 'push', + set_array => 'set', + }, + clearer => 'clear_array', + trigger => sub { @TriggerArgs = @_ }, + ); +} + +my $foo = Foo->new; + +{ + $foo->array( [ 1, 2, 3 ] ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [ 1, 2, 3 ] ], + 'trigger was called for normal writer' + ); + + $foo->push_array(5); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [ 1, 2, 3, 5 ], [ 1, 2, 3 ] ], + 'trigger was called on push' + ); + + $foo->set_array( 1, 42 ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [ 1, 42, 3, 5 ], [ 1, 2, 3, 5 ] ], + 'trigger was called on set' + ); +} + +done_testing; diff --git a/t/native_traits/collection_with_roles.t b/t/native_traits/collection_with_roles.t new file mode 100644 index 0000000..6d75675 --- /dev/null +++ b/t/native_traits/collection_with_roles.t @@ -0,0 +1,122 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Subject; + + use Moose::Role; + + has observers => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Observer]', + auto_deref => 1, + default => sub { [] }, + handles => { + 'add_observer' => 'push', + 'count_observers' => 'count', + }, + ); + + sub notify { + my ($self) = @_; + foreach my $observer ( $self->observers() ) { + $observer->update($self); + } + } +} + +{ + package Observer; + + use Moose::Role; + + requires 'update'; +} + +{ + package Counter; + + use Moose; + + with 'Subject'; + + has count => ( + traits => ['Counter'], + is => 'ro', + isa => 'Int', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + }, + ); + + after qw(inc_counter dec_counter) => sub { + my ($self) = @_; + $self->notify(); + }; +} + +{ + + package Display; + + use Test::More; + + use Moose; + + with 'Observer'; + + sub update { + my ( $self, $subject ) = @_; + like $subject->count, qr{^-?\d+$}, + 'Observed number ' . $subject->count; + } +} + +package main; + +my $count = Counter->new(); + +ok( $count->can('add_observer'), 'add_observer method added' ); + +ok( $count->can('count_observers'), 'count_observers method added' ); + +ok( $count->can('inc_counter'), 'inc_counter method added' ); + +ok( $count->can('dec_counter'), 'dec_counter method added' ); + +$count->add_observer( Display->new() ); + +is( $count->count_observers, 1, 'Only one observer' ); + +is( $count->count, 0, 'Default to zero' ); + +$count->inc_counter; + +is( $count->count, 1, 'Increment to one ' ); + +$count->inc_counter for ( 1 .. 6 ); + +is( $count->count, 7, 'Increment up to seven' ); + +$count->dec_counter; + +is( $count->count, 6, 'Decrement to 6' ); + +$count->dec_counter for ( 1 .. 5 ); + +is( $count->count, 1, 'Decrement to 1' ); + +$count->dec_counter for ( 1 .. 2 ); + +is( $count->count, -1, 'Negative numbers' ); + +$count->inc_counter; + +is( $count->count, 0, 'Back to zero' ); + +done_testing; diff --git a/t/native_traits/custom_instance.t b/t/native_traits/custom_instance.t new file mode 100644 index 0000000..0b08339 --- /dev/null +++ b/t/native_traits/custom_instance.t @@ -0,0 +1,246 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package ValueContainer; + use Moose; + + has value => ( + is => 'rw', + ); +} + +{ + package Foo::Meta::Instance; + use Moose::Role; + + around get_slot_value => sub { + my $orig = shift; + my $self = shift; + my ($instance, $slot_name) = @_; + my $value = $self->$orig(@_); + if ($value->isa('ValueContainer')) { + $value = $value->value; + } + return $value; + }; + + around inline_get_slot_value => sub { + my $orig = shift; + my $self = shift; + my $value = $self->$orig(@_); + return q[do {] . "\n" + . q[ my $value = ] . $value . q[;] . "\n" + . q[ if ($value->isa('ValueContainer')) {] . "\n" + . q[ $value = $value->value;] . "\n" + . q[ }] . "\n" + . q[ $value] . "\n" + . q[}]; + }; + + sub inline_get_is_lvalue { 0 } +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['Foo::Meta::Instance'], + } + ); + + ::is( ::exception { + has array => ( + traits => ['Array'], + isa => 'ArrayRef', + default => sub { [] }, + handles => { + array_count => 'count', + array_elements => 'elements', + array_is_empty => 'is_empty', + array_push => 'push', + array_push_curried => [ push => 42, 84 ], + array_unshift => 'unshift', + array_unshift_curried => [ unshift => 42, 84 ], + array_pop => 'pop', + array_shift => 'shift', + array_get => 'get', + array_get_curried => [ get => 1 ], + array_set => 'set', + array_set_curried_1 => [ set => 1 ], + array_set_curried_2 => [ set => ( 1, 98 ) ], + array_accessor => 'accessor', + array_accessor_curried_1 => [ accessor => 1 ], + array_accessor_curried_2 => [ accessor => ( 1, 90 ) ], + array_clear => 'clear', + array_delete => 'delete', + array_delete_curried => [ delete => 1 ], + array_insert => 'insert', + array_insert_curried => [ insert => ( 1, 101 ) ], + array_splice => 'splice', + array_splice_curried_1 => [ splice => 1 ], + array_splice_curried_2 => [ splice => 1, 2 ], + array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + array_sort => 'sort', + array_sort_curried => + [ sort => ( sub { $_[1] <=> $_[0] } ) ], + array_sort_in_place => 'sort_in_place', + array_sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + array_map => 'map', + array_map_curried => [ map => ( sub { $_ + 1 } ) ], + array_grep => 'grep', + array_grep_curried => [ grep => ( sub { $_ < 5 } ) ], + array_first => 'first', + array_first_curried => [ first => ( sub { $_ % 2 } ) ], + array_join => 'join', + array_join_curried => [ join => '-' ], + array_shuffle => 'shuffle', + array_uniq => 'uniq', + array_reduce => 'reduce', + array_reduce_curried => + [ reduce => ( sub { $_[0] * $_[1] } ) ], + array_natatime => 'natatime', + array_natatime_curried => [ natatime => 2 ], + }, + ); + }, undef, "native array trait inlines properly" ); + + ::is( ::exception { + has bool => ( + traits => ['Bool'], + isa => 'Bool', + default => 0, + handles => { + bool_illuminate => 'set', + bool_darken => 'unset', + bool_flip_switch => 'toggle', + bool_is_dark => 'not', + }, + ); + }, undef, "native bool trait inlines properly" ); + + ::is( ::exception { + has code => ( + traits => ['Code'], + isa => 'CodeRef', + default => sub { sub { } }, + handles => { + code_execute => 'execute', + code_execute_method => 'execute_method', + }, + ); + }, undef, "native code trait inlines properly" ); + + ::is( ::exception { + has counter => ( + traits => ['Counter'], + isa => 'Int', + default => 0, + handles => { + inc_counter => 'inc', + inc_counter_2 => [ inc => 2 ], + dec_counter => 'dec', + dec_counter_2 => [ dec => 2 ], + reset_counter => 'reset', + set_counter => 'set', + set_counter_42 => [ set => 42 ], + }, + ); + }, undef, "native counter trait inlines properly" ); + + ::is( ::exception { + has hash => ( + traits => ['Hash'], + isa => 'HashRef', + default => sub { {} }, + handles => { + hash_option_accessor => 'accessor', + hash_quantity => [ accessor => 'quantity' ], + hash_clear_options => 'clear', + hash_num_options => 'count', + hash_delete_option => 'delete', + hash_is_defined => 'defined', + hash_options_elements => 'elements', + hash_has_option => 'exists', + hash_get_option => 'get', + hash_has_no_options => 'is_empty', + hash_key_value => 'kv', + hash_set_option => 'set', + }, + ); + }, undef, "native hash trait inlines properly" ); + + ::is( ::exception { + has number => ( + traits => ['Number'], + isa => 'Num', + default => 0, + handles => { + num_abs => 'abs', + num_add => 'add', + num_inc => [ add => 1 ], + num_div => 'div', + num_cut_in_half => [ div => 2 ], + num_mod => 'mod', + num_odd => [ mod => 2 ], + num_mul => 'mul', + num_set => 'set', + num_sub => 'sub', + num_dec => [ sub => 1 ], + }, + ); + }, undef, "native number trait inlines properly" ); + + ::is( ::exception { + has string => ( + traits => ['String'], + is => 'ro', + isa => 'Str', + default => '', + handles => { + string_inc => 'inc', + string_append => 'append', + string_append_curried => [ append => '!' ], + string_prepend => 'prepend', + string_prepend_curried => [ prepend => '-' ], + string_replace => 'replace', + string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], + string_chop => 'chop', + string_chomp => 'chomp', + string_clear => 'clear', + string_match => 'match', + string_match_curried => [ match => qr/\D/ ], + string_length => 'length', + string_substr => 'substr', + string_substr_curried_1 => [ substr => (1) ], + string_substr_curried_2 => [ substr => ( 1, 3 ) ], + string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], + }, + ); + }, undef, "native string trait inlines properly" ); +} + +with_immutable { + { + my $foo = Foo->new(string => 'a'); + is($foo->string, 'a'); + $foo->string_append('b'); + is($foo->string, 'ab'); + } + + { + my $foo = Foo->new(string => ''); + $foo->{string} = ValueContainer->new(value => 'a'); + is($foo->string, 'a'); + $foo->string_append('b'); + is($foo->string, 'ab'); + } +} 'Foo'; + +done_testing; diff --git a/t/native_traits/hash_coerce.t b/t/native_traits/hash_coerce.t new file mode 100644 index 0000000..23d4093 --- /dev/null +++ b/t/native_traits/hash_coerce.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'UCHash', as 'HashRef[Str]', where { + !grep {/[a-z]/} values %{$_}; + }; + + coerce 'UCHash', from 'HashRef[Str]', via { + $_ = uc $_ for values %{$_}; + $_; + }; + + has hash => ( + traits => ['Hash'], + is => 'rw', + isa => 'UCHash', + coerce => 1, + handles => { + set_key => 'set', + }, + ); + + our @TriggerArgs; + + has lazy => ( + traits => ['Hash'], + is => 'rw', + isa => 'UCHash', + coerce => 1, + lazy => 1, + default => sub { { x => 'a' } }, + handles => { + set_lazy => 'set', + }, + trigger => sub { @TriggerArgs = @_ }, + clearer => 'clear_lazy', + ); +} + +my $foo = Foo->new; + +{ + $foo->hash( { x => 'A', y => 'B' } ); + + $foo->set_key( z => 'c' ); + + is_deeply( + $foo->hash, { x => 'A', y => 'B', z => 'C' }, + 'set coerces the hash' + ); +} + +{ + $foo->set_lazy( y => 'b' ); + + is_deeply( + $foo->lazy, { x => 'A', y => 'B' }, + 'set coerces the hash - lazy' + ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ], + 'trigger receives expected arguments' + ); +} + +{ + package Thing; + use Moose; + + has thing => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + class_type 'Thing'; + + coerce 'Thing' + => from 'Str' + => via { Thing->new( thing => $_ ) }; + + subtype 'HashRefOfThings' + => as 'HashRef[Thing]'; + + coerce 'HashRefOfThings' + => from 'HashRef[Str]' + => via { + my %new; + for my $k ( keys %{$_} ) { + $new{$k} = Thing->new( thing => $_->{$k} ); + } + return \%new; + }; + + coerce 'HashRefOfThings' + => from 'Str' + => via { [ Thing->new( thing => $_ ) ] }; + + has hash => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRefOfThings', + coerce => 1, + handles => { + set_hash => 'set', + get_hash => 'get', + }, + ); +} + +{ + my $bar = Bar->new( hash => { foo => 1, bar => 2 } ); + + is( + $bar->get_hash('foo')->thing, 1, + 'constructor coerces hash reference' + ); + + $bar->set_hash( baz => 3, quux => 4 ); + + is( + $bar->get_hash('baz')->thing, 3, + 'set coerces new hash values' + ); + + is( + $bar->get_hash('quux')->thing, 4, + 'set coerces new hash values' + ); +} + + +done_testing; diff --git a/t/native_traits/hash_subtypes.t b/t/native_traits/hash_subtypes.t new file mode 100644 index 0000000..ff7eb96 --- /dev/null +++ b/t/native_traits/hash_subtypes.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + use Moose::Util::TypeConstraints; + use List::Util qw( sum ); + + subtype 'H1', as 'HashRef[Int]'; + subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 }; + subtype 'H3', as 'HashRef[Int]', + where { ( sum( values %{$_} ) || 0 ) < 5 }; + + subtype 'H5', as 'HashRef'; + coerce 'H5', from 'Str', via { { key => $_ } }; + + no Moose::Util::TypeConstraints; +} + +{ + + package Foo; + use Moose; + + has hash_int => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef[Int]', + handles => { + set_hash_int => 'set', + }, + ); + + has h1 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H1', + handles => { + set_h1 => 'set', + }, + ); + + has h2 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H2', + handles => { + set_h2 => 'set', + }, + ); + + has h3 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H3', + handles => { + set_h3 => 'set', + }, + ); + + has h4 => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef', + lazy => 1, + default => 'invalid', + clearer => '_clear_h4', + handles => { + get_h4 => 'get', + accessor_h4 => 'accessor', + }, + ); + + has h5 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H5', + coerce => 1, + lazy => 1, + default => 'invalid', + clearer => '_clear_h5', + handles => { + get_h5 => 'get', + accessor_h5 => 'accessor', + }, + ); +} + +my $foo = Foo->new; + +{ + $foo->hash_int( {} ); + is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); + + isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" ); + is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); + + $foo->set_hash_int( x => 1 ); + is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" ); +} + +{ + isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" ); + + $foo->h1( {} ); + is_deeply( $foo->h1, {}, "h1 - correct contents" ); + + isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" ); + + is_deeply( $foo->h1, {}, "h1 - correct contents" ); + + $foo->set_h1( x => 1 ); + is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" ); +} + +{ + isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" ); + + $foo->h2( {} ); + is_deeply( $foo->h2, {}, "h2 - correct contents" ); + + $foo->set_h2( x => 'foo' ); + is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); + + isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" ); + + is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); +} + +{ + isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" ); + + $foo->h3( {} ); + is_deeply( $foo->h3, {}, "h3 - correct contents" ); + + isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" ); + + isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); + + is_deeply( $foo->h3, {}, "h3 - correct contents" ); + + $foo->set_h3( x => 1 ); + is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); + + isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); + + is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); + + $foo->set_h3( y => 3 ); + is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" ); +} + +{ + my $expect + = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value \E.*invalid.*/; + + like( + exception { $foo->accessor_h4('key'); }, + $expect, + 'invalid default is caught when trying to read via accessor' + ); + + like( + exception { $foo->accessor_h4( size => 42 ); }, + $expect, + 'invalid default is caught when trying to write via accessor' + ); + + like( + exception { $foo->get_h4(42); }, + $expect, + 'invalid default is caught when trying to get' + ); +} + +{ + my $foo = Foo->new; + + is( + $foo->accessor_h5('key'), 'invalid', + 'lazy default is coerced when trying to read via accessor' + ); + + $foo->_clear_h5; + + $foo->accessor_h5( size => 42 ); + + is_deeply( + $foo->h5, + { key => 'invalid', size => 42 }, + 'lazy default is coerced when trying to write via accessor' + ); + + $foo->_clear_h5; + + is( + $foo->get_h5('key'), 'invalid', + 'lazy default is coerced when trying to get' + ); +} + +done_testing; diff --git a/t/native_traits/hash_trigger.t b/t/native_traits/hash_trigger.t new file mode 100644 index 0000000..1618f3c --- /dev/null +++ b/t/native_traits/hash_trigger.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Foo; + use Moose; + + our @TriggerArgs; + + has hash => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef', + handles => { + delete_key => 'delete', + set_key => 'set', + }, + clearer => 'clear_key', + trigger => sub { @TriggerArgs = @_ }, + ); +} + +my $foo = Foo->new; + +{ + $foo->hash( { x => 1, y => 2 } ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 1, y => 2 } ], + 'trigger was called for normal writer' + ); + + $foo->set_key( z => 5 ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 1, y => 2, z => 5 }, { x => 1, y => 2 } ], + 'trigger was called on set' + ); + + $foo->delete_key('y'); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 1, z => 5 }, { x => 1, y => 2, z => 5 } ], + 'trigger was called on delete' + ); +} + +done_testing; diff --git a/t/native_traits/remove_attribute.t b/t/native_traits/remove_attribute.t new file mode 100644 index 0000000..f1c7cbe --- /dev/null +++ b/t/native_traits/remove_attribute.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package MyHomePage; + use Moose; + + has 'counter' => ( + traits => ['Counter'], + is => 'ro', + isa => 'Int', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + reset_counter => 'reset', + } + ); +} + +my $page = MyHomePage->new(); +isa_ok( $page, 'MyHomePage' ); + +can_ok( $page, $_ ) for qw[ + counter + dec_counter + inc_counter + reset_counter +]; + +is( exception { + $page->meta->remove_attribute('counter'); +}, undef, '... removed the counter attribute okay' ); + +ok( !$page->meta->has_attribute('counter'), + '... no longer has the attribute' ); + +ok( !$page->can($_), "... our class no longer has the $_ method" ) for qw[ + counter + dec_counter + inc_counter + reset_counter +]; + +done_testing; diff --git a/t/native_traits/shallow_clone.t b/t/native_traits/shallow_clone.t new file mode 100644 index 0000000..6f25a3f --- /dev/null +++ b/t/native_traits/shallow_clone.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; +use Scalar::Util qw(refaddr); + +{ + package Foo; + use Moose; + + has 'array' => ( + traits => ['Array'], + is => 'ro', + handles => { array_clone => 'shallow_clone' }, + ); + + has 'hash' => ( + traits => ['Hash'], + is => 'ro', + handles => { hash_clone => 'shallow_clone' }, + ); + + no Moose; +} + +my $array = [ 1, 2, 3 ]; +my $hash = { a => 1, b => 2 }; + +my $obj = Foo->new({ + array => $array, + hash => $hash, +}); + +my $array_clone = $obj->array_clone; +my $hash_clone = $obj->hash_clone; + +isnt(refaddr($array), refaddr($array_clone), "array clone refers to new copy"); +is_deeply($array_clone, $array, "...but contents are the same"); +isnt(refaddr($hash), refaddr($hash_clone), "hash clone refers to new copy"); +is_deeply($hash_clone, $hash, "...but contents are the same"); + +done_testing; diff --git a/t/native_traits/trait_array.t b/t/native_traits/trait_array.t new file mode 100644 index 0000000..0435583 --- /dev/null +++ b/t/native_traits/trait_array.t @@ -0,0 +1,740 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + my %handles = ( + count => 'count', + elements => 'elements', + is_empty => 'is_empty', + push => 'push', + push_curried => + [ push => 42, 84 ], + unshift => 'unshift', + unshift_curried => + [ unshift => 42, 84 ], + pop => 'pop', + shift => 'shift', + get => 'get', + get_curried => [ get => 1 ], + set => 'set', + set_curried_1 => [ set => 1 ], + set_curried_2 => [ set => ( 1, 98 ) ], + accessor => 'accessor', + accessor_curried_1 => [ accessor => 1 ], + accessor_curried_2 => [ accessor => ( 1, 90 ) ], + clear => 'clear', + delete => 'delete', + delete_curried => [ delete => 1 ], + insert => 'insert', + insert_curried => [ insert => ( 1, 101 ) ], + splice => 'splice', + splice_curried_1 => [ splice => 1 ], + splice_curried_2 => [ splice => 1, 2 ], + splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + sort => 'sort', + sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], + sort_in_place => 'sort_in_place', + sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + map => 'map', + map_curried => [ map => ( sub { $_ + 1 } ) ], + grep => 'grep', + grep_curried => [ grep => ( sub { $_ < 5 } ) ], + first => 'first', + first_curried => [ first => ( sub { $_ % 2 } ) ], + first_index => 'first_index', + first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], + join => 'join', + join_curried => [ join => '-' ], + shuffle => 'shuffle', + uniq => 'uniq', + reduce => 'reduce', + reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], + natatime => 'natatime', + natatime_curried => [ natatime => 2 ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Array'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + _values => ( + traits => \@traits, + is => 'rw', + isa => 'ArrayRef[Int]', + default => sub { [] }, + handles => \%handles, + clearer => '_clear_values', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + package Overloader; + + use overload + '&{}' => sub { ${ $_[0] } }, + bool => sub {1}; + + sub new { + bless \$_[1], $_[0]; + } +} + +{ + package OverloadStr; + use overload + q{""} => sub { ${ $_[0] } }, + fallback => 1; + + sub new { + my $class = shift; + my $str = shift; + return bless \$str, $class; + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire arrayref when it is modified. + subtype 'MyArrayRef', as 'ArrayRef', where { 1 }; + + run_tests( build_class( isa => 'MyArrayRef' ) ); + + coerce 'MyArrayRef', from 'ArrayRef', via { $_ }; + + run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new( _values => [ 10, 12, 42 ] ); + + is_deeply( + $obj->_values, [ 10, 12, 42 ], + 'values can be set in constructor' + ); + + ok( !$obj->is_empty, 'values is not empty' ); + is( $obj->count, 3, 'count returns 3' ); + + like( exception { $obj->count(22) }, qr/Cannot call count with any arguments/, 'throws an error when passing an argument passed to count' ); + + is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); + + is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); + + is( exception { + is( $obj->unshift( 101, 22 ), 8, + 'unshift returns size of the new array' ); + }, undef, 'unshifted two values and lived' ); + + is_deeply( + $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], + 'unshift changed the value of the array in the object' + ); + + is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); + + is( $obj->pop, 3, 'pop returns the last value in the array' ); + + is_deeply( + $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], + 'pop changed the value of the array in the object' + ); + + like( exception { $obj->pop(42) }, qr/Cannot call pop with any arguments/, 'call to pop with arguments dies' ); + + is( $obj->shift, 101, 'shift returns the first value' ); + + like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, 'call to shift with arguments dies' ); + + is_deeply( + $obj->_values, [ 22, 10, 12, 42, 1, 2 ], + 'shift changed the value of the array in the object' + ); + + is_deeply( + [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], + 'call to elements returns values as a list' + ); + + is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); + + like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, 'throws an error when passing an argument passed to elements' ); + + $obj->_values( [ 1, 2, 3 ] ); + + is( $obj->get(0), 1, 'get values at index 0' ); + is( $obj->get(1), 2, 'get values at index 1' ); + is( $obj->get(2), 3, 'get values at index 2' ); + is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); + + like( exception { $obj->get() }, qr/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' ); + + like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); + + like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); + + like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); + + like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, 'throws an error when get_curried is called with an argument' ); + + is( exception { + is( $obj->set( 1, 100 ), 100, 'set returns new value' ); + }, undef, 'set value at index 1 lives' ); + + is( $obj->get(1), 100, 'get value at index 1 returns new value' ); + + + like( exception { $obj->set( 1, 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set is called with three arguments' ); + + is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); + + is( $obj->get(1), 99, 'get value at index 1 returns new value' ); + + like( exception { $obj->set_curried_1( 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_1 is called with two arguments' ); + + is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); + + is( $obj->get(1), 98, 'get value at index 1 returns new value' ); + + like( exception { $obj->set_curried_2(42) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' ); + + is( + $obj->accessor(1), 98, + 'accessor with one argument returns value at index 1' + ); + + is( exception { + is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); + }, undef, 'accessor as writer lives' ); + + like( + exception { + $obj->accessor; + }, + qr/Cannot call accessor without at least 1 argument/, + 'throws an error when accessor is called without arguments' + ); + + is( + $obj->get(1), 97, + 'accessor set value at index 1' + ); + + like( exception { $obj->accessor( 1, 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor is called with three arguments' ); + + is( + $obj->accessor_curried_1, 97, + 'accessor_curried_1 returns expected value when called with no arguments' + ); + + is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); + + is( + $obj->get(1), 95, + 'accessor_curried_1 set value at index 1' + ); + + like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_1 is called with two arguments' ); + + is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); + + is( + $obj->get(1), 90, + 'accessor_curried_2 set value at index 1' + ); + + like( exception { $obj->accessor_curried_2(42) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_2 is called with one argument' ); + + is( exception { $obj->clear }, undef, 'clear lives' ); + + ok( $obj->is_empty, 'values is empty after call to clear' ); + + is( exception { + is( $obj->shift, undef, + 'shift returns undef on an empty array' ); + }, undef, 'shifted from an empty array and lived' ); + + $obj->set( 0 => 42 ); + + like( exception { $obj->clear(50) }, qr/Cannot call clear with any arguments/, 'throws an error when clear is called with an argument' ); + + ok( + !$obj->is_empty, + 'values is not empty after failed call to clear' + ); + + like( exception { $obj->is_empty(50) }, qr/Cannot call is_empty with any arguments/, 'throws an error when is_empty is called with an argument' ); + + $obj->clear; + is( + $obj->push( 1, 5, 10, 42 ), 4, + 'pushed 4 elements, got number of elements in the array back' + ); + + is( exception { + is( $obj->delete(2), 10, 'delete returns deleted value' ); + }, undef, 'delete lives' ); + + is_deeply( + $obj->_values, [ 1, 5, 42 ], + 'delete removed the specified element' + ); + + like( exception { $obj->delete( 2, 3 ) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete is called with two arguments' ); + + is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); + + is_deeply( + $obj->_values, [ 1, 42 ], + 'delete removed the specified element' + ); + + like( exception { $obj->delete_curried(2) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete_curried is called with one argument' ); + + is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); + + is_deeply( + $obj->_values, [ 1, 21, 42 ], + 'insert added the specified element' + ); + + like( exception { $obj->insert( 1, 22, 44 ) }, qr/Cannot call insert with more than 2 arguments/, 'throws an error when insert is called with three arguments' ); + + is( exception { + is_deeply( + [ $obj->splice( 1, 0, 2, 3 ) ], + [], + 'return value of splice is empty list when not removing elements' + ); + }, undef, 'splice lives' ); + + is_deeply( + $obj->_values, [ 1, 2, 3, 21, 42 ], + 'splice added the specified elements' + ); + + is( exception { + is_deeply( + [ $obj->splice( 1, 2, 99 ) ], + [ 2, 3 ], + 'splice returns list of removed values' + ); + }, undef, 'splice lives' ); + + is_deeply( + $obj->_values, [ 1, 99, 21, 42 ], + 'splice added the specified elements' + ); + + like( exception { $obj->splice() }, qr/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' ); + + like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, 'throws an error when splice is called with an invalid length' ); + + is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); + + is_deeply( + $obj->_values, [ 1, 101, 42 ], + 'splice added the specified elements' + ); + + is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); + + is_deeply( + $obj->_values, [ 1, 102 ], + 'splice added the specified elements' + ); + + is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); + + is_deeply( + $obj->_values, [ 1, 3, 4, 5 ], + 'splice added the specified elements' + ); + + is_deeply( + scalar $obj->splice( 1, 2 ), + 4, + 'splice in scalar context returns last element removed' + ); + + is_deeply( + scalar $obj->splice( 1, 0, 42 ), + undef, + 'splice in scalar context returns undef when no elements are removed' + ); + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + is_deeply( + [ $obj->sort ], [ 11, 22, 3, 5, 9 ], + 'sort returns sorted values' + ); + + is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); + + is_deeply( + [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], + 'sort returns values sorted by provided function' + ); + + is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); + + like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' ); + + like( exception { + $obj->sort( sub { }, 27 ); + }, qr/Cannot call sort with more than 1 argument/, 'throws an error when passing two arguments to sort' ); + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + $obj->sort_in_place; + + is_deeply( + $obj->_values, [ 11, 22, 3, 5, 9 ], + 'sort_in_place sorts values' + ); + + $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); + + is_deeply( + $obj->_values, [ 3, 5, 9, 11, 22 ], + 'sort_in_place with function sorts values' + ); + + like( exception { + $obj->sort_in_place( 27 ); + }, qr/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' ); + + like( exception { + $obj->sort_in_place( sub { }, 27 ); + }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing two arguments to sort_in_place' ); + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + $obj->sort_in_place_curried; + + is_deeply( + $obj->_values, [ 22, 11, 9, 5, 3 ], + 'sort_in_place_curried sorts values' + ); + + like( exception { $obj->sort_in_place_curried(27) }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing one argument passed to sort_in_place_curried' ); + + $obj->_values( [ 1 .. 5 ] ); + + is_deeply( + [ $obj->map( sub { $_ + 1 } ) ], + [ 2 .. 6 ], + 'map returns the expected values' + ); + + like( exception { $obj->map }, qr/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' ); + + like( exception { + $obj->map( sub { }, 2 ); + }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' ); + + like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, 'throws an error when passing a non coderef to map' ); + + $obj->_values( [ 1 .. 5 ] ); + + is_deeply( + [ $obj->map_curried ], + [ 2 .. 6 ], + 'map_curried returns the expected values' + ); + + like( exception { + $obj->map_curried( sub { } ); + }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing one argument passed to map_curried' ); + + $obj->_values( [ 2 .. 9 ] ); + + is_deeply( + [ $obj->grep( sub { $_ < 5 } ) ], + [ 2 .. 4 ], + 'grep returns the expected values' + ); + + like( exception { $obj->grep }, qr/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' ); + + like( exception { + $obj->grep( sub { }, 2 ); + }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' ); + + like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, 'throws an error when passing a non coderef to grep' ); + + my $overloader = Overloader->new( sub { $_ < 5 } ); + is_deeply( + [ $obj->grep($overloader) ], + [ 2 .. 4 ], + 'grep works with obj that overload code dereferencing' + ); + + is_deeply( + [ $obj->grep_curried ], + [ 2 .. 4 ], + 'grep_curried returns the expected values' + ); + + like( exception { + $obj->grep_curried( sub { } ); + }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing one argument passed to grep_curried' ); + + $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); + + is( + $obj->first( sub { $_ % 2 } ), + 99, + 'first returns expected value' + ); + + like( exception { $obj->first }, qr/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' ); + + like( exception { + $obj->first( sub { }, 2 ); + }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' ); + + like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, 'throws an error when passing a non coderef to first' ); + + is( + $obj->first_curried, + 99, + 'first_curried returns expected value' + ); + + like( exception { + $obj->first_curried( sub { } ); + }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing one argument passed to first_curried' ); + + + is( + $obj->first_index( sub { $_ % 2 } ), + 3, + 'first_index returns expected value' + ); + + like( exception { $obj->first_index }, qr/Cannot call first_index without at least 1 argument/, 'throws an error when passing no arguments to first_index' ); + + like( exception { + $obj->first_index( sub { }, 2 ); + }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing two arguments to first_index' ); + + like( exception { $obj->first_index( {} ) }, qr/The argument passed to first_index must be a code reference/, 'throws an error when passing a non coderef to first_index' ); + + is( + $obj->first_index_curried, + 3, + 'first_index_curried returns expected value' + ); + + like( exception { + $obj->first_index_curried( sub { } ); + }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing one argument passed to first_index_curried' ); + + + $obj->_values( [ 1 .. 4 ] ); + + is( + $obj->join('-'), '1-2-3-4', + 'join returns expected result' + ); + + is( + $obj->join(q{}), '1234', + 'join returns expected result when joining with empty string' + ); + + is( + $obj->join( OverloadStr->new(q{}) ), '1234', + 'join returns expected result when joining with empty string' + ); + + like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' ); + + like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' ); + + like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, 'throws an error when passing a non string to join' ); + + is_deeply( + [ sort $obj->shuffle ], + [ 1 .. 4 ], + 'shuffle returns all values (cannot check for a random order)' + ); + + like( exception { $obj->shuffle(2) }, qr/Cannot call shuffle with any arguments/, 'throws an error when passing an argument passed to shuffle' ); + + $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); + + is_deeply( + [ $obj->uniq ], + [ 1 .. 4, 5, 7 ], + 'uniq returns expected values (in original order)' + ); + + like( exception { $obj->uniq(2) }, qr/Cannot call uniq with any arguments/, 'throws an error when passing an argument passed to uniq' ); + + $obj->_values( [ 1 .. 5 ] ); + + is( + $obj->reduce( sub { $_[0] * $_[1] } ), + 120, + 'reduce returns expected value' + ); + + like( exception { $obj->reduce }, qr/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' ); + + like( exception { + $obj->reduce( sub { }, 2 ); + }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' ); + + like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, 'throws an error when passing a non coderef to reduce' ); + + is( + $obj->reduce_curried, + 120, + 'reduce_curried returns expected value' + ); + + like( exception { + $obj->reduce_curried( sub { } ); + }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing one argument passed to reduce_curried' ); + + $obj->_values( [ 1 .. 6 ] ); + + my $it = $obj->natatime(2); + my @nat; + while ( my @v = $it->() ) { + push @nat, \@v; + } + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime returns expected iterator' + ); + + @nat = (); + $obj->natatime( 2, sub { push @nat, [@_] } ); + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime with function returns expected value' + ); + + like( exception { $obj->natatime( {} ) }, qr/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' ); + + like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime' ); + + $it = $obj->natatime_curried(); + @nat = (); + while ( my @v = $it->() ) { + push @nat, \@v; + } + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime_curried returns expected iterator' + ); + + @nat = (); + $obj->natatime_curried( sub { push @nat, [@_] } ); + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime_curried with function returns expected value' + ); + + like( exception { $obj->natatime_curried( {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' ); + + if ( $class->meta->get_attribute('_values')->is_lazy ) { + my $obj = $class->new; + + is( $obj->count, 2, 'count is 2 (lazy init)' ); + + $obj->_clear_values; + + is_deeply( + [ $obj->elements ], [ 42, 84 ], + 'elements contains default with lazy init' + ); + + $obj->_clear_values; + + $obj->push(2); + + is_deeply( + $obj->_values, [ 42, 84, 2 ], + 'push works with lazy init' + ); + + $obj->_clear_values; + + $obj->unshift( 3, 4 ); + + is_deeply( + $obj->_values, [ 3, 4, 42, 84 ], + 'unshift works with lazy init' + ); + } + } + $class; +} + +{ + my ( $class, $handles ) = build_class( isa => 'ArrayRef' ); + my $obj = $class->new; + with_immutable { + is( + exception { $obj->accessor( 0, undef ) }, + undef, + 'can use accessor to set value to undef' + ); + is( + exception { $obj->accessor_curried_1(undef) }, + undef, + 'can use curried accessor to set value to undef' + ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_bool.t b/t/native_traits/trait_bool.t new file mode 100644 index 0000000..7a416da --- /dev/null +++ b/t/native_traits/trait_bool.t @@ -0,0 +1,101 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + my %handles = ( + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Bool'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + is_lit => ( + traits => \@traits, + is => 'rw', + isa => 'Bool', + default => 0, + handles => \%handles, + clearer => '_clear_is_list', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1 ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyBool', as 'Bool', where { 1 }; + + run_tests( build_class( isa => 'MyBool' ) ); + + coerce 'MyBool', from 'Bool', via { $_ }; + + run_tests( build_class( isa => 'MyBool', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new; + + ok( $obj->illuminate, 'set returns true' ); + ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); + ok( !$obj->is_dark, 'check if is_dark does the right thing' ); + + like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' ); + + ok( !$obj->darken, 'unset returns false' ); + ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); + ok( $obj->is_dark, 'check if is_dark does the right thing' ); + + like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' ); + + ok( $obj->flip_switch, 'toggle returns new value' ); + ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); + ok( !$obj->is_dark, 'check if is_dark does the right thing' ); + + like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' ); + + $obj->flip_switch; + ok( !$obj->is_lit, + 'toggle is_lit back to 0 again using ->flip_switch' ); + ok( $obj->is_dark, 'check if is_dark does the right thing' ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_code.t b/t/native_traits/trait_code.t new file mode 100644 index 0000000..1590963 --- /dev/null +++ b/t/native_traits/trait_code.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use NoInlineAttribute; +use Test::More; +use Test::Moose; + +{ + my $name = 'Foo1'; + + sub build_class { + my ( $attr1, $attr2, $attr3, $no_inline ) = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Code'; + push @traits, 'NoInlineAttribute' + if $no_inline; + + $class->add_attribute( + callback => ( + traits => \@traits, + isa => 'CodeRef', + required => 1, + handles => { 'invoke_callback' => 'execute' }, + %{ $attr1 || {} }, + ) + ); + + $class->add_attribute( + callback_method => ( + traits => \@traits, + isa => 'CodeRef', + required => 1, + handles => { 'invoke_method_callback' => 'execute_method' }, + %{ $attr2 || {} }, + ) + ); + + $class->add_attribute( + multiplier => ( + traits => \@traits, + isa => 'CodeRef', + required => 1, + handles => { 'multiply' => 'execute' }, + %{ $attr3 || {} }, + ) + ); + + return $class->name; + } +} + +{ + my $i; + + my %subs = ( + callback => sub { ++$i }, + callback_method => sub { shift->multiply(@_) }, + multiplier => sub { $_[0] * 2 }, + ); + + run_tests( build_class, \$i, \%subs ); + + run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); + + run_tests( + build_class( + { + lazy => 1, default => sub { $subs{callback} } + }, { + lazy => 1, default => sub { $subs{callback_method} } + }, { + lazy => 1, default => sub { $subs{multiplier} } + }, + ), + \$i, + ); +} + +sub run_tests { + my ( $class, $iref, @args ) = @_; + + ok( + !$class->can($_), + "Code trait didn't create reader method for $_" + ) for qw(callback callback_method multiplier); + + with_immutable { + ${$iref} = 0; + my $obj = $class->new(@args); + + $obj->invoke_callback; + + is( ${$iref}, 1, '$i is 1 after invoke_callback' ); + + is( + $obj->invoke_method_callback(3), 6, + 'invoke_method_callback calls multiply with @_' + ); + + is( $obj->multiply(3), 6, 'multiple double value' ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_counter.t b/t/native_traits/trait_counter.t new file mode 100644 index 0000000..9a9901c --- /dev/null +++ b/t/native_traits/trait_counter.t @@ -0,0 +1,170 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::Fatal; +use Test::More; +use Test::Moose; + +{ + my %handles = ( + inc_counter => 'inc', + inc_counter_2 => [ inc => 2 ], + dec_counter => 'dec', + dec_counter_2 => [ dec => 2 ], + reset_counter => 'reset', + set_counter => 'set', + set_counter_42 => [ set => 42 ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Counter'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + counter => ( + traits => \@traits, + is => 'ro', + isa => 'Int', + default => 0, + handles => \%handles, + clearer => '_clear_counter', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1 ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyInt', as 'Int', where { 1 }; + + run_tests( build_class( isa => 'MyInt' ) ); + + coerce 'MyInt', from 'Int', via { $_ }; + + run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new(); + + is( $obj->counter, 0, '... got the default value' ); + + is( $obj->inc_counter, 1, 'inc returns new value' ); + is( $obj->counter, 1, '... got the incremented value' ); + + is( $obj->inc_counter, 2, 'inc returns new value' ); + is( $obj->counter, 2, '... got the incremented value (again)' ); + + like( exception { $obj->inc_counter( 1, 2 ) }, qr/Cannot call inc with more than 1 argument/, 'inc throws an error when two arguments are passed' ); + + is( $obj->dec_counter, 1, 'dec returns new value' ); + is( $obj->counter, 1, '... got the decremented value' ); + + like( exception { $obj->dec_counter( 1, 2 ) }, qr/Cannot call dec with more than 1 argument/, 'dec throws an error when two arguments are passed' ); + + is( $obj->reset_counter, 0, 'reset returns new value' ); + is( $obj->counter, 0, '... got the original value' ); + + like( exception { $obj->reset_counter(2) }, qr/Cannot call reset with any arguments/, 'reset throws an error when an argument is passed' ); + + is( $obj->set_counter(5), 5, 'set returns new value' ); + is( $obj->counter, 5, '... set the value' ); + + like( exception { $obj->set_counter( 1, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when two arguments are passed' ); + + $obj->inc_counter(2); + is( $obj->counter, 7, '... increment by arg' ); + + $obj->dec_counter(5); + is( $obj->counter, 2, '... decrement by arg' ); + + $obj->inc_counter_2; + is( $obj->counter, 4, '... curried increment' ); + + $obj->dec_counter_2; + is( $obj->counter, 2, '... curried deccrement' ); + + $obj->set_counter_42; + is( $obj->counter, 42, '... curried set' ); + + if ( $class->meta->get_attribute('counter')->is_lazy ) { + my $obj = $class->new; + + $obj->inc_counter; + is( $obj->counter, 1, 'inc increments - with lazy default' ); + + $obj->_clear_counter; + + $obj->dec_counter; + is( $obj->counter, -1, 'dec decrements - with lazy default' ); + } + } + $class; +} + +{ + package WithBuilder; + use Moose; + + has nonlazy => ( + traits => ['Counter'], + is => 'rw', + isa => 'Int', + builder => '_builder', + handles => { + reset_nonlazy => 'reset', + }, + ); + + has lazy => ( + traits => ['Counter'], + is => 'rw', + isa => 'Int', + lazy => 1, + builder => '_builder', + handles => { + reset_lazy => 'reset', + }, + ); + + sub _builder { 1 } +} + +for my $attr ('lazy', 'nonlazy') { + my $obj = WithBuilder->new; + is($obj->$attr, 1, "built properly"); + $obj->$attr(0); + is($obj->$attr, 0, "can be manually set"); + $obj->${\"reset_$attr"}; + is($obj->$attr, 1, "reset resets it to its default value"); +} + +done_testing; diff --git a/t/native_traits/trait_hash.t b/t/native_traits/trait_hash.t new file mode 100644 index 0000000..c957108 --- /dev/null +++ b/t/native_traits/trait_hash.t @@ -0,0 +1,329 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::Fatal; +use Test::More; +use Test::Moose; + +{ + my %handles = ( + option_accessor => 'accessor', + quantity => [ accessor => 'quantity' ], + clear_options => 'clear', + num_options => 'count', + delete_option => 'delete', + is_defined => 'defined', + options_elements => 'elements', + has_option => 'exists', + get_option => 'get', + has_no_options => 'is_empty', + keys => 'keys', + values => 'values', + key_value => 'kv', + set_option => 'set', + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Hash'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + options => ( + traits => \@traits, + is => 'rw', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => \%handles, + clearer => '_clear_options', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyHashRef', as 'HashRef[Str]', where { 1 }; + + run_tests( build_class( isa => 'MyHashRef' ) ); + + coerce 'MyHashRef', from 'HashRef', via { $_ }; + + run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new( options => {} ); + + ok( $obj->has_no_options, '... we have no options' ); + is( $obj->num_options, 0, '... we have no options' ); + + is_deeply( $obj->options, {}, '... no options yet' ); + ok( !$obj->has_option('foo'), '... we have no foo option' ); + + is( exception { + is( + $obj->set_option( foo => 'bar' ), + 'bar', + 'set return single new value in scalar context' + ); + }, undef, '... set the option okay' ); + + like( + exception { $obj->set_option( foo => 'bar', 'baz' ) }, + qr/You must pass an even number of arguments to set/, + 'exception with odd number of arguments' + ); + + like( + exception { $obj->set_option( undef, 'bar' ) }, + qr/Hash keys passed to set must be defined/, + 'exception when using undef as a key' + ); + + ok( $obj->is_defined('foo'), '... foo is defined' ); + + ok( !$obj->has_no_options, '... we have options' ); + is( $obj->num_options, 1, '... we have 1 option(s)' ); + ok( $obj->has_option('foo'), '... we have a foo option' ); + is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); + + is( exception { + $obj->set_option( bar => 'baz' ); + }, undef, '... set the option okay' ); + + is( $obj->num_options, 2, '... we have 2 option(s)' ); + is_deeply( + $obj->options, { foo => 'bar', bar => 'baz' }, + '... got more options now' + ); + + is( $obj->get_option('foo'), 'bar', '... got the right option' ); + + is_deeply( + [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], + "get multiple options at once" + ); + + is( + scalar( $obj->get_option(qw( foo bar)) ), "baz", + '... got last option in scalar context' + ); + + is( exception { + $obj->set_option( oink => "blah", xxy => "flop" ); + }, undef, '... set the option okay' ); + + is( $obj->num_options, 4, "4 options" ); + is_deeply( + [ $obj->get_option(qw(foo bar oink xxy)) ], + [qw(bar baz blah flop)], "get multiple options at once" + ); + + is( exception { + is( scalar $obj->delete_option('bar'), 'baz', + 'delete returns deleted value' ); + }, undef, '... deleted the option okay' ); + + is( exception { + is_deeply( + [ $obj->delete_option( 'oink', 'xxy' ) ], + [ 'blah', 'flop' ], + 'delete returns all deleted values in list context' + ); + }, undef, '... deleted multiple option okay' ); + + is( $obj->num_options, 1, '... we have 1 option(s)' ); + is_deeply( + $obj->options, { foo => 'bar' }, + '... got more options now' + ); + + $obj->clear_options; + + is_deeply( $obj->options, {}, "... cleared options" ); + + is( exception { + $obj->quantity(4); + }, undef, '... options added okay with defaults' ); + + is( $obj->quantity, 4, 'reader part of curried accessor works' ); + + is( + $obj->option_accessor('quantity'), 4, + 'accessor as reader' + ); + + is_deeply( + $obj->options, { quantity => 4 }, + '... returns what we expect' + ); + + $obj->option_accessor( size => 42 ); + + like( + exception { + $obj->option_accessor; + }, + qr/Cannot call accessor without at least 1 argument/, + 'error when calling accessor with no arguments' + ); + + like( + exception { $obj->option_accessor( undef, 'bar' ) }, + qr/Hash keys passed to accessor must be defined/, + 'exception when using undef as a key' + ); + + is_deeply( + $obj->options, { quantity => 4, size => 42 }, + 'accessor as writer' + ); + + is( exception { + $class->new( options => { foo => 'BAR' } ); + }, undef, '... good constructor params' ); + + isnt( exception { + $obj->set_option( bar => {} ); + }, undef, '... could not add a hash ref where an string is expected' ); + + isnt( exception { + $class->new( options => { foo => [] } ); + }, undef, '... bad constructor params' ); + + $obj->options( {} ); + + is_deeply( + [ $obj->set_option( oink => "blah", xxy => "flop" ) ], + [ 'blah', 'flop' ], + 'set returns newly set values in order of keys provided' + ); + + is_deeply( + [ sort $obj->keys ], + [ 'oink', 'xxy' ], + 'keys returns expected keys' + ); + + is_deeply( + [ sort $obj->values ], + [ 'blah', 'flop' ], + 'values returns expected values' + ); + + my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; + is_deeply( + \@key_value, + [ + sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], + [ 'oink', 'blah' ] + ], + '... got the right key value pairs' + ) + or do { + require Data::Dumper; + diag( Data::Dumper::Dumper( \@key_value ) ); + }; + + my %options_elements = $obj->options_elements; + is_deeply( + \%options_elements, { + 'oink' => 'blah', + 'xxy' => 'flop' + }, + '... got the right hash elements' + ); + + if ( $class->meta->get_attribute('options')->is_lazy ) { + my $obj = $class->new; + + $obj->set_option( y => 2 ); + + is_deeply( + $obj->options, { x => 1, y => 2 }, + 'set_option with lazy default' + ); + + $obj->_clear_options; + + ok( + $obj->has_option('x'), + 'key for x exists - lazy default' + ); + + $obj->_clear_options; + + ok( + $obj->is_defined('x'), + 'key for x is defined - lazy default' + ); + + $obj->_clear_options; + + is_deeply( + [ $obj->key_value ], + [ [ x => 1 ] ], + 'kv returns lazy default' + ); + + $obj->_clear_options; + + $obj->option_accessor( y => 2 ); + + is_deeply( + [ sort $obj->keys ], + [ 'x', 'y' ], + 'accessor triggers lazy default generator' + ); + } + } + $class; +} + +{ + my ( $class, $handles ) = build_class( isa => 'HashRef' ); + my $obj = $class->new; + with_immutable { + is( + exception { $obj->option_accessor( 'foo', undef ) }, + undef, + 'can use accessor to set value to undef' + ); + is( + exception { $obj->quantity(undef) }, + undef, + 'can use accessor to set value to undef' + ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_number.t b/t/native_traits/trait_number.t new file mode 100644 index 0000000..addf4bf --- /dev/null +++ b/t/native_traits/trait_number.t @@ -0,0 +1,161 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::Fatal; +use Test::More; +use Test::Moose; + +{ + my %handles = ( + abs => 'abs', + add => 'add', + inc => [ add => 1 ], + div => 'div', + cut_in_half => [ div => 2 ], + mod => 'mod', + odd => [ mod => 2 ], + mul => 'mul', + set => 'set', + sub => 'sub', + dec => [ sub => 1 ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Number'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + integer => ( + traits => \@traits, + is => 'ro', + isa => 'Int', + default => 5, + handles => \%handles, + clearer => '_clear_integer', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1 ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyInt', as 'Int', where { 1 }; + + run_tests( build_class( isa => 'MyInt' ) ); + + coerce 'MyInt', from 'Int', via { $_ }; + + run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new; + + is( $obj->integer, 5, 'Default to five' ); + + is( $obj->add(10), 15, 'add returns new value' ); + + is( $obj->integer, 15, 'Add ten for fithteen' ); + + like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' ); + + is( $obj->sub(3), 12, 'sub returns new value' ); + + is( $obj->integer, 12, 'Subtract three for 12' ); + + like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' ); + + is( $obj->set(10), 10, 'set returns new value' ); + + is( $obj->integer, 10, 'Set to ten' ); + + like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' ); + + is( $obj->div(2), 5, 'div returns new value' ); + + is( $obj->integer, 5, 'divide by 2' ); + + like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' ); + + is( $obj->mul(2), 10, 'mul returns new value' ); + + is( $obj->integer, 10, 'multiplied by 2' ); + + like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' ); + + is( $obj->mod(2), 0, 'mod returns new value' ); + + is( $obj->integer, 0, 'Mod by 2' ); + + like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' ); + + $obj->set(7); + + $obj->mod(5); + + is( $obj->integer, 2, 'Mod by 5' ); + + $obj->set(-1); + + is( $obj->abs, 1, 'abs returns new value' ); + + like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' ); + + is( $obj->integer, 1, 'abs 1' ); + + $obj->set(12); + + $obj->inc; + + is( $obj->integer, 13, 'inc 12' ); + + $obj->dec; + + is( $obj->integer, 12, 'dec 13' ); + + if ( $class->meta->get_attribute('integer')->is_lazy ) { + my $obj = $class->new; + + $obj->add(2); + + is( $obj->integer, 7, 'add with lazy default' ); + + $obj->_clear_integer; + + $obj->mod(2); + + is( $obj->integer, 1, 'mod with lazy default' ); + } + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_string.t b/t/native_traits/trait_string.t new file mode 100644 index 0000000..7f834f5 --- /dev/null +++ b/t/native_traits/trait_string.t @@ -0,0 +1,303 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + my %handles = ( + inc => 'inc', + append => 'append', + append_curried => [ append => '!' ], + prepend => 'prepend', + prepend_curried => [ prepend => '-' ], + replace => 'replace', + replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], + chop => 'chop', + chomp => 'chomp', + clear => 'clear', + match => 'match', + match_curried => [ match => qr/\D/ ], + length => 'length', + substr => 'substr', + substr_curried_1 => [ substr => (1) ], + substr_curried_2 => [ substr => ( 1, 3 ) ], + substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'String'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + _string => ( + traits => \@traits, + is => 'rw', + isa => 'Str', + default => q{}, + handles => \%handles, + clearer => '_clear_string', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1, default => q{} ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyStr', as 'Str', where { 1 }; + + run_tests( build_class( isa => 'MyStr' ) ); + + coerce 'MyStr', from 'Str', via { $_ }; + + run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new(); + + is( $obj->length, 0, 'length returns zero' ); + + $obj->_string('a'); + is( $obj->length, 1, 'length returns 1 for new string' ); + + like( exception { $obj->length(42) }, qr/Cannot call length with any arguments/, 'length throws an error when an argument is passed' ); + + is( $obj->inc, 'b', 'inc returns new value' ); + is( $obj->_string, 'b', 'a becomes b after inc' ); + + like( exception { $obj->inc(42) }, qr/Cannot call inc with any arguments/, 'inc throws an error when an argument is passed' ); + + is( $obj->append('foo'), 'bfoo', 'append returns new value' ); + is( $obj->_string, 'bfoo', 'appended to the string' ); + + like( exception { $obj->append( 'foo', 2 ) }, qr/Cannot call append with more than 1 argument/, 'append throws an error when two arguments are passed' ); + + $obj->append_curried; + is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); + + like( exception { $obj->append_curried('foo') }, qr/Cannot call append with more than 1 argument/, 'append_curried throws an error when two arguments are passed' ); + + $obj->_string("has nl$/"); + is( $obj->chomp, 1, 'chomp returns number of characters removed' ); + is( $obj->_string, 'has nl', 'chomped string' ); + + is( $obj->chomp, 0, 'chomp returns number of characters removed' ); + is( + $obj->_string, 'has nl', + 'chomp is a no-op when string has no line ending' + ); + + like( exception { $obj->chomp(42) }, qr/Cannot call chomp with any arguments/, 'chomp throws an error when an argument is passed' ); + + is( $obj->chop, 'l', 'chop returns character removed' ); + is( $obj->_string, 'has n', 'chopped string' ); + + like( exception { $obj->chop(42) }, qr/Cannot call chop with any arguments/, 'chop throws an error when an argument is passed' ); + + $obj->_string('x'); + is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); + is( $obj->_string, 'barx', 'prepended to string' ); + + $obj->prepend_curried; + is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); + + is( + $obj->replace( qr/([ao])/, sub { uc($1) } ), + '-bArx', + 'replace returns new value' + ); + + is( + $obj->_string, '-bArx', + 'substitution using coderef for replacement' + ); + + $obj->replace( qr/A/, 'X' ); + is( + $obj->_string, '-bXrx', + 'substitution using string as replacement' + ); + + $obj->_string('foo'); + $obj->replace( qr/oo/, q{} ); + + is( $obj->_string, 'f', + 'replace accepts an empty string as second argument' ); + + $obj->replace( q{}, 'a' ); + + is( $obj->_string, 'af', + 'replace accepts an empty string as first argument' ); + + like( exception { $obj->replace( {}, 'x' ) }, qr/The first argument passed to replace must be a string or regexp reference/, 'replace throws an error when the first argument is not a string or regexp' ); + + like( exception { $obj->replace( qr/x/, {} ) }, qr/The second argument passed to replace must be a string or code reference/, 'replace throws an error when the first argument is not a string or regexp' ); + + $obj->_string('Moosex'); + $obj->replace_curried; + is( $obj->_string, 'MooseX', 'capitalize last' ); + + $obj->_string('abcdef'); + + is_deeply( + [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], + 'match -barx against /[aq]/ returns matches' + ); + + is_deeply( + [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], + 'match -barx against /[aq]/ returns matches' + ); + + ok( + scalar $obj->match('b'), + 'match with string as argument returns true' + ); + + ok( + scalar $obj->match(q{}), + 'match with empty string as argument returns true' + ); + + like( exception { $obj->match }, qr/Cannot call match without at least 1 argument/, 'match throws an error when no arguments are passed' ); + + like( exception { $obj->match( {} ) }, qr/The argument passed to match must be a string or regexp reference/, 'match throws an error when an invalid argument is passed' ); + + $obj->_string('1234'); + ok( !$obj->match_curried, 'match_curried returns false' ); + + $obj->_string('one two three four'); + ok( $obj->match_curried, 'match curried returns true' ); + + $obj->clear; + is( $obj->_string, q{}, 'clear' ); + + like( exception { $obj->clear(42) }, qr/Cannot call clear with any arguments/, 'clear throws an error when an argument is passed' ); + + $obj->_string('some long string'); + is( + $obj->substr(1), 'ome long string', + 'substr as getter with one argument' + ); + + $obj->_string('some long string'); + is( + $obj->substr( 1, 3 ), 'ome', + 'substr as getter with two arguments' + ); + + is( + $obj->substr( 1, 3, 'ong' ), + 'ome', + 'substr as setter returns replaced string' + ); + + is( + $obj->_string, 'song long string', + 'substr as setter with three arguments' + ); + + $obj->substr( 1, 3, '' ); + + is( + $obj->_string, 's long string', + 'substr as setter with three arguments, replacment is empty string' + ); + + like( exception { $obj->substr }, qr/Cannot call substr without at least 1 argument/, 'substr throws an error when no argumemts are passed' ); + + like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/Cannot call substr with more than 3 arguments/, 'substr throws an error when four argumemts are passed' ); + + like( exception { $obj->substr( {} ) }, qr/The first argument passed to substr must be an integer/, 'substr throws an error when first argument is not an integer' ); + + like( exception { $obj->substr( 1, {} ) }, qr/The second argument passed to substr must be an integer/, 'substr throws an error when second argument is not an integer' ); + + like( exception { $obj->substr( 1, 2, {} ) }, qr/The third argument passed to substr must be a string/, 'substr throws an error when third argument is not a string' ); + + $obj->_string('some long string'); + + is( + $obj->substr_curried_1, 'ome long string', + 'substr_curried_1 returns expected value' + ); + + is( + $obj->substr_curried_1(3), 'ome', + 'substr_curried_1 with one argument returns expected value' + ); + + $obj->substr_curried_1( 3, 'ong' ); + + is( + $obj->_string, 'song long string', + 'substr_curried_1 as setter with two arguments' + ); + + $obj->_string('some long string'); + + is( + $obj->substr_curried_2, 'ome', + 'substr_curried_2 returns expected value' + ); + + $obj->substr_curried_2('ong'); + + is( + $obj->_string, 'song long string', + 'substr_curried_2 as setter with one arguments' + ); + + $obj->_string('some long string'); + + $obj->substr_curried_3; + + is( + $obj->_string, 'song long string', + 'substr_curried_3 as setter' + ); + + if ( $class->meta->get_attribute('_string')->is_lazy ) { + my $obj = $class->new; + + $obj->append('foo'); + + is( + $obj->_string, 'foo', + 'append with lazy default' + ); + } + } + $class; +} + +done_testing; diff --git a/t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t b/t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t new file mode 100644 index 0000000..8cf7bf3 --- /dev/null +++ b/t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t @@ -0,0 +1,154 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package BankAccount; + use Moose; + + has 'balance' => ( isa => 'Int', is => 'rw', default => 0 ); + + sub deposit { + my ( $self, $amount ) = @_; + $self->balance( $self->balance + $amount ); + } + + sub withdraw { + my ( $self, $amount ) = @_; + my $current_balance = $self->balance(); + ( $current_balance >= $amount ) + || confess "Account overdrawn"; + $self->balance( $current_balance - $amount ); + } + + package CheckingAccount; + use Moose; + + extends 'BankAccount'; + + has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' ); + + before 'withdraw' => sub { + my ( $self, $amount ) = @_; + my $overdraft_amount = $amount - $self->balance(); + if ( $self->overdraft_account && $overdraft_amount > 0 ) { + $self->overdraft_account->withdraw($overdraft_amount); + $self->deposit($overdraft_amount); + } + }; +} + + + +# =begin testing +{ +my $savings_account; + +{ + $savings_account = BankAccount->new( balance => 250 ); + isa_ok( $savings_account, 'BankAccount' ); + + is( $savings_account->balance, 250, '... got the right savings balance' ); + is( + exception { + $savings_account->withdraw(50); + }, + undef, + '... withdrew from savings successfully' + ); + is( $savings_account->balance, 200, + '... got the right savings balance after withdrawal' ); + + $savings_account->deposit(150); + is( $savings_account->balance, 350, + '... got the right savings balance after deposit' ); +} + +{ + my $checking_account = CheckingAccount->new( + balance => 100, + overdraft_account => $savings_account + ); + isa_ok( $checking_account, 'CheckingAccount' ); + isa_ok( $checking_account, 'BankAccount' ); + + is( $checking_account->overdraft_account, $savings_account, + '... got the right overdraft account' ); + + is( $checking_account->balance, 100, + '... got the right checkings balance' ); + + is( + exception { + $checking_account->withdraw(50); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); + is( $savings_account->balance, 350, + '... got the right savings balance after checking withdrawal (no overdraft)' + ); + + is( + exception { + $checking_account->withdraw(200); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 0, + '... got the right checkings balance after withdrawal' ); + is( $savings_account->balance, 200, + '... got the right savings balance after overdraft withdrawal' ); +} + +{ + my $checking_account = CheckingAccount->new( + balance => 100 + + # no overdraft account + ); + isa_ok( $checking_account, 'CheckingAccount' ); + isa_ok( $checking_account, 'BankAccount' ); + + is( $checking_account->overdraft_account, undef, + '... no overdraft account' ); + + is( $checking_account->balance, 100, + '... got the right checkings balance' ); + + is( + exception { + $checking_account->withdraw(50); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); + + isnt( + exception { + $checking_account->withdraw(200); + }, + undef, + '... withdrawal failed due to attempted overdraft' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal failure' ); +} +} + + + + +1; diff --git a/t/recipes/basics_binarytree_attributefeatures.t b/t/recipes/basics_binarytree_attributefeatures.t new file mode 100644 index 0000000..87222fd --- /dev/null +++ b/t/recipes/basics_binarytree_attributefeatures.t @@ -0,0 +1,174 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package BinaryTree; + use Moose; + + has 'node' => ( is => 'rw', isa => 'Any' ); + + has 'parent' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_parent', + weak_ref => 1, + ); + + has 'left' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_left', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + + has 'right' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_right', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + + sub _set_parent_for_child { + my ( $self, $child ) = @_; + + confess "You cannot insert a tree which already has a parent" + if $child->has_parent; + + $child->parent($self); + } +} + + + +# =begin testing +{ +use Scalar::Util 'isweak'; + +my $root = BinaryTree->new(node => 'root'); +isa_ok($root, 'BinaryTree'); + +is($root->node, 'root', '... got the right node value'); + +ok(!$root->has_left, '... no left node yet'); +ok(!$root->has_right, '... no right node yet'); + +ok(!$root->has_parent, '... no parent for root node'); + +# make a left node + +my $left = $root->left; +isa_ok($left, 'BinaryTree'); + +is($root->left, $left, '... got the same node (and it is $left)'); +ok($root->has_left, '... we have a left node now'); + +ok($left->has_parent, '... lefts has a parent'); +is($left->parent, $root, '... lefts parent is the root'); + +ok(isweak($left->{parent}), '... parent is a weakened ref'); + +ok(!$left->has_left, '... $left no left node yet'); +ok(!$left->has_right, '... $left no right node yet'); + +is($left->node, undef, '... left has got no node value'); + +is( + exception { + $left->node('left'); + }, + undef, + '... assign to lefts node' +); + +is($left->node, 'left', '... left now has a node value'); + +# make a right node + +ok(!$root->has_right, '... still no right node yet'); + +is($root->right->node, undef, '... right has got no node value'); + +ok($root->has_right, '... now we have a right node'); + +my $right = $root->right; +isa_ok($right, 'BinaryTree'); + +is( + exception { + $right->node('right'); + }, + undef, + '... assign to rights node' +); + +is($right->node, 'right', '... left now has a node value'); + +is($root->right, $right, '... got the same node (and it is $right)'); +ok($root->has_right, '... we have a right node now'); + +ok($right->has_parent, '... rights has a parent'); +is($right->parent, $root, '... rights parent is the root'); + +ok(isweak($right->{parent}), '... parent is a weakened ref'); + +# make a left node of the left node + +my $left_left = $left->left; +isa_ok($left_left, 'BinaryTree'); + +ok($left_left->has_parent, '... left does have a parent'); + +is($left_left->parent, $left, '... got a parent node (and it is $left)'); +ok($left->has_left, '... we have a left node now'); +is($left->left, $left_left, '... got a left node (and it is $left_left)'); + +ok(isweak($left_left->{parent}), '... parent is a weakened ref'); + +# make a right node of the left node + +my $left_right = BinaryTree->new; +isa_ok($left_right, 'BinaryTree'); + +is( + exception { + $left->right($left_right); + }, + undef, + '... assign to rights node' +); + +ok($left_right->has_parent, '... left does have a parent'); + +is($left_right->parent, $left, '... got a parent node (and it is $left)'); +ok($left->has_right, '... we have a left node now'); +is($left->right, $left_right, '... got a left node (and it is $left_left)'); + +ok(isweak($left_right->{parent}), '... parent is a weakened ref'); + +# and check the error + +isnt( + exception { + $left_right->right($left_left); + }, + undef, + '... cannot assign a node which already has a parent' +); +} + + + + +1; diff --git a/t/recipes/basics_company_subtypes.t b/t/recipes/basics_company_subtypes.t new file mode 100644 index 0000000..89c76ee --- /dev/null +++ b/t/recipes/basics_company_subtypes.t @@ -0,0 +1,356 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +use Test::Requires { + 'Locale::US' => '0', + 'Regexp::Common' => '0', +}; + + + +# =begin testing SETUP +{ + + package Address; + use Moose; + use Moose::Util::TypeConstraints; + + use Locale::US; + use Regexp::Common 'zip'; + + my $STATES = Locale::US->new; + subtype 'USState' + => as Str + => where { + ( exists $STATES->{code2state}{ uc($_) } + || exists $STATES->{state2code}{ uc($_) } ); + }; + + subtype 'USZipCode' + => as Value + => where { + /^$RE{zip}{US}{-extended => 'allow'}$/; + }; + + has 'street' => ( is => 'rw', isa => 'Str' ); + has 'city' => ( is => 'rw', isa => 'Str' ); + has 'state' => ( is => 'rw', isa => 'USState' ); + has 'zip_code' => ( is => 'rw', isa => 'USZipCode' ); + + package Company; + use Moose; + use Moose::Util::TypeConstraints; + + has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'address' => ( is => 'rw', isa => 'Address' ); + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]', + default => sub { [] }, + ); + + sub BUILD { + my ( $self, $params ) = @_; + foreach my $employee ( @{ $self->employees } ) { + $employee->employer($self); + } + } + + after 'employees' => sub { + my ( $self, $employees ) = @_; + return unless $employees; + foreach my $employee ( @$employees ) { + $employee->employer($self); + } + }; + + package Person; + use Moose; + + has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'middle_initial' => ( + is => 'rw', isa => 'Str', + predicate => 'has_middle_initial' + ); + has 'address' => ( is => 'rw', isa => 'Address' ); + + sub full_name { + my $self = shift; + return $self->first_name + . ( + $self->has_middle_initial + ? ' ' . $self->middle_initial . '. ' + : ' ' + ) . $self->last_name; + } + + package Employee; + use Moose; + + extends 'Person'; + + has 'title' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 ); + + override 'full_name' => sub { + my $self = shift; + super() . ', ' . $self->title; + }; +} + + + +# =begin testing +{ +{ + package Company; + + sub get_employee_count { scalar @{(shift)->employees} } +} + +use Scalar::Util 'isweak'; + +my $ii; +is( + exception { + $ii = Company->new( + { + name => 'Infinity Interactive', + address => Address->new( + street => '565 Plandome Rd., Suite 307', + city => 'Manhasset', + state => 'NY', + zip_code => '11030' + ), + employees => [ + Employee->new( + first_name => 'Jeremy', + last_name => 'Shao', + title => 'President / Senior Consultant', + address => Address->new( + city => 'Manhasset', state => 'NY' + ) + ), + Employee->new( + first_name => 'Tommy', + last_name => 'Lee', + title => 'Vice President / Senior Developer', + address => + Address->new( city => 'New York', state => 'NY' ) + ), + Employee->new( + first_name => 'Stevan', + middle_initial => 'C', + last_name => 'Little', + title => 'Senior Developer', + address => + Address->new( city => 'Madison', state => 'CT' ) + ), + ] + } + ); + }, + undef, + '... created the entire company successfully' +); + +isa_ok( $ii, 'Company' ); + +is( $ii->name, 'Infinity Interactive', + '... got the right name for the company' ); + +isa_ok( $ii->address, 'Address' ); +is( $ii->address->street, '565 Plandome Rd., Suite 307', + '... got the right street address' ); +is( $ii->address->city, 'Manhasset', '... got the right city' ); +is( $ii->address->state, 'NY', '... got the right state' ); +is( $ii->address->zip_code, 11030, '... got the zip code' ); + +is( $ii->get_employee_count, 3, '... got the right employee count' ); + +# employee #1 + +isa_ok( $ii->employees->[0], 'Employee' ); +isa_ok( $ii->employees->[0], 'Person' ); + +is( $ii->employees->[0]->first_name, 'Jeremy', + '... got the right first name' ); +is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' ); +ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' ); +is( $ii->employees->[0]->middle_initial, undef, + '... got the right middle initial value' ); +is( $ii->employees->[0]->full_name, + 'Jeremy Shao, President / Senior Consultant', + '... got the right full name' ); +is( $ii->employees->[0]->title, 'President / Senior Consultant', + '... got the right title' ); +is( $ii->employees->[0]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[0]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[0]->address, 'Address' ); +is( $ii->employees->[0]->address->city, 'Manhasset', + '... got the right city' ); +is( $ii->employees->[0]->address->state, 'NY', '... got the right state' ); + +# employee #2 + +isa_ok( $ii->employees->[1], 'Employee' ); +isa_ok( $ii->employees->[1], 'Person' ); + +is( $ii->employees->[1]->first_name, 'Tommy', + '... got the right first name' ); +is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' ); +ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' ); +is( $ii->employees->[1]->middle_initial, undef, + '... got the right middle initial value' ); +is( $ii->employees->[1]->full_name, + 'Tommy Lee, Vice President / Senior Developer', + '... got the right full name' ); +is( $ii->employees->[1]->title, 'Vice President / Senior Developer', + '... got the right title' ); +is( $ii->employees->[1]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[1]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[1]->address, 'Address' ); +is( $ii->employees->[1]->address->city, 'New York', + '... got the right city' ); +is( $ii->employees->[1]->address->state, 'NY', '... got the right state' ); + +# employee #3 + +isa_ok( $ii->employees->[2], 'Employee' ); +isa_ok( $ii->employees->[2], 'Person' ); + +is( $ii->employees->[2]->first_name, 'Stevan', + '... got the right first name' ); +is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' ); +ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' ); +is( $ii->employees->[2]->middle_initial, 'C', + '... got the right middle initial value' ); +is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', + '... got the right full name' ); +is( $ii->employees->[2]->title, 'Senior Developer', + '... got the right title' ); +is( $ii->employees->[2]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[2]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[2]->address, 'Address' ); +is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' ); +is( $ii->employees->[2]->address->state, 'CT', '... got the right state' ); + +# create new company + +my $new_company + = Company->new( name => 'Infinity Interactive International' ); +isa_ok( $new_company, 'Company' ); + +my $ii_employees = $ii->employees; +foreach my $employee (@$ii_employees) { + is( $employee->employer, $ii, '... has the ii company' ); +} + +$new_company->employees($ii_employees); + +foreach my $employee ( @{ $new_company->employees } ) { + is( $employee->employer, $new_company, + '... has the different company now' ); +} + +## check some error conditions for the subtypes + +isnt( + exception { + Address->new( street => {} ),; + }, + undef, + '... we die correctly with bad args' +); + +isnt( + exception { + Address->new( city => {} ),; + }, + undef, + '... we die correctly with bad args' +); + +isnt( + exception { + Address->new( state => 'British Columbia' ),; + }, + undef, + '... we die correctly with bad args' +); + +is( + exception { + Address->new( state => 'Connecticut' ),; + }, + undef, + '... we live correctly with good args' +); + +isnt( + exception { + Address->new( zip_code => 'AF5J6$' ),; + }, + undef, + '... we die correctly with bad args' +); + +is( + exception { + Address->new( zip_code => '06443' ),; + }, + undef, + '... we live correctly with good args' +); + +isnt( + exception { + Company->new(),; + }, + undef, + '... we die correctly without good args' +); + +is( + exception { + Company->new( name => 'Foo' ),; + }, + undef, + '... we live correctly without good args' +); + +isnt( + exception { + Company->new( name => 'Foo', employees => [ Person->new ] ),; + }, + undef, + '... we die correctly with good args' +); + +is( + exception { + Company->new( name => 'Foo', employees => [] ),; + }, + undef, + '... we live correctly with good args' +); +} + + + + +1; diff --git a/t/recipes/basics_datetime_extendingnonmooseparent.t b/t/recipes/basics_datetime_extendingnonmooseparent.t new file mode 100644 index 0000000..cf55a62 --- /dev/null +++ b/t/recipes/basics_datetime_extendingnonmooseparent.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +# because MooseX::NonMoose has a version requirement +BEGIN { $Moose::Role::VERSION = 9999 unless $Moose::Role::VERSION } + +use Test::Requires { + 'DateTime' => '0', + 'DateTime::Calendar::Mayan' => '0', + 'MooseX::NonMoose' => '0.25', +}; + + + +# =begin testing SETUP +{ + + package My::DateTime; + + use Moose; + use MooseX::NonMoose; + use DateTime::Calendar::Mayan; + extends qw( DateTime ); + + has 'mayan_date' => ( + is => 'ro', + isa => 'DateTime::Calendar::Mayan', + init_arg => undef, + lazy => 1, + builder => '_build_mayan_date', + clearer => '_clear_mayan_date', + predicate => 'has_mayan_date', + ); + + after 'set' => sub { + $_[0]->_clear_mayan_date; + }; + + sub _build_mayan_date { + DateTime::Calendar::Mayan->from_object( object => $_[0] ); + } +} + + + +# =begin testing +{ +my $dt = My::DateTime->new( year => 1970, month => 2, day => 24 ); + +can_ok( $dt, 'mayan_date' ); +isa_ok( $dt->mayan_date, 'DateTime::Calendar::Mayan' ); +is( $dt->mayan_date->date, '12.17.16.9.19', 'got expected mayan date' ); + +$dt->set( year => 2009 ); +ok( ! $dt->has_mayan_date, 'mayan_date is cleared after call to ->set' ); +} + + + + +1; diff --git a/t/recipes/basics_document_augmentandinner.t b/t/recipes/basics_document_augmentandinner.t new file mode 100644 index 0000000..dc59b06 --- /dev/null +++ b/t/recipes/basics_document_augmentandinner.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Document::Page; + use Moose; + + has 'body' => ( is => 'rw', isa => 'Str', default => sub {''} ); + + sub create { + my $self = shift; + $self->open_page; + inner(); + $self->close_page; + } + + sub append_body { + my ( $self, $appendage ) = @_; + $self->body( $self->body . $appendage ); + } + + sub open_page { (shift)->append_body('<page>') } + sub close_page { (shift)->append_body('</page>') } + + package Document::PageWithHeadersAndFooters; + use Moose; + + extends 'Document::Page'; + + augment 'create' => sub { + my $self = shift; + $self->create_header; + inner(); + $self->create_footer; + }; + + sub create_header { (shift)->append_body('<header/>') } + sub create_footer { (shift)->append_body('<footer/>') } + + package TPSReport; + use Moose; + + extends 'Document::PageWithHeadersAndFooters'; + + augment 'create' => sub { + my $self = shift; + $self->create_tps_report; + inner(); + }; + + sub create_tps_report { + (shift)->append_body('<report type="tps"/>'); + } + + # <page><header/><report type="tps"/><footer/></page> + my $report_xml = TPSReport->new->create; +} + + + +# =begin testing +{ +my $tps_report = TPSReport->new; +isa_ok( $tps_report, 'TPSReport' ); + +is( + $tps_report->create, + q{<page><header/><report type="tps"/><footer/></page>}, + '... got the right TPS report' +); +} + + + + +1; diff --git a/t/recipes/basics_genome_overloadingsubtypesandcoercion.t b/t/recipes/basics_genome_overloadingsubtypesandcoercion.t new file mode 100644 index 0000000..4283986 --- /dev/null +++ b/t/recipes/basics_genome_overloadingsubtypesandcoercion.t @@ -0,0 +1,219 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Human; + + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Sex' + => as 'Str' + => where { $_ =~ m{^[mf]$}s }; + + has 'sex' => ( is => 'ro', isa => 'Sex', required => 1 ); + + has 'mother' => ( is => 'ro', isa => 'Human' ); + has 'father' => ( is => 'ro', isa => 'Human' ); + + use overload '+' => \&_overload_add, fallback => 1; + + sub _overload_add { + my ( $one, $two ) = @_; + + die('Only male and female humans may create children') + if ( $one->sex() eq $two->sex() ); + + my ( $mother, $father ) + = ( $one->sex eq 'f' ? ( $one, $two ) : ( $two, $one ) ); + + my $sex = 'f'; + $sex = 'm' if ( rand() >= 0.5 ); + + return Human->new( + sex => $sex, + eye_color => ( $one->eye_color() + $two->eye_color() ), + mother => $mother, + father => $father, + ); + } + + use List::MoreUtils qw( zip ); + + coerce 'Human::EyeColor' + => from 'ArrayRef' + => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); + return Human::EyeColor->new( zip( @genes, @{$_} ) ); }; + + has 'eye_color' => ( + is => 'ro', + isa => 'Human::EyeColor', + coerce => 1, + required => 1, + ); + +} + +{ + package Human::Gene::bey2; + + use Moose; + use Moose::Util::TypeConstraints; + + type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} }; + + has 'color' => ( is => 'ro', isa => 'bey2_color' ); +} + +{ + package Human::Gene::gey; + + use Moose; + use Moose::Util::TypeConstraints; + + type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} }; + + has 'color' => ( is => 'ro', isa => 'gey_color' ); +} + +{ + package Human::EyeColor; + + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Human::Gene::bey2' + => from 'Str' + => via { Human::Gene::bey2->new( color => $_ ) }; + + coerce 'Human::Gene::gey' + => from 'Str' + => via { Human::Gene::gey->new( color => $_ ) }; + + has [qw( bey2_1 bey2_2 )] => + ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 ); + + has [qw( gey_1 gey_2 )] => + ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 ); + + sub color { + my ($self) = @_; + + return 'brown' + if ( $self->bey2_1->color() eq 'brown' + or $self->bey2_2->color() eq 'brown' ); + + return 'green' + if ( $self->gey_1->color() eq 'green' + or $self->gey_2->color() eq 'green' ); + + return 'blue'; + } + + use overload '""' => \&color, fallback => 1; + + use overload '+' => \&_overload_add, fallback => 1; + + sub _overload_add { + my ( $one, $two ) = @_; + + my $one_bey2 = 'bey2_' . _rand2(); + my $two_bey2 = 'bey2_' . _rand2(); + + my $one_gey = 'gey_' . _rand2(); + my $two_gey = 'gey_' . _rand2(); + + return Human::EyeColor->new( + bey2_1 => $one->$one_bey2->color(), + bey2_2 => $two->$two_bey2->color(), + gey_1 => $one->$one_gey->color(), + gey_2 => $two->$two_gey->color(), + ); + } + + sub _rand2 { + return 1 + int( rand(2) ); + } +} + +my $gene_color_sets = [ + [ qw( blue blue blue blue ) => 'blue' ], + [ qw( blue blue green blue ) => 'green' ], + [ qw( blue blue blue green ) => 'green' ], + [ qw( blue blue green green ) => 'green' ], + [ qw( brown blue blue blue ) => 'brown' ], + [ qw( brown brown green green ) => 'brown' ], + [ qw( blue brown green blue ) => 'brown' ], +]; + +foreach my $set (@$gene_color_sets) { + my $expected_color = pop(@$set); + + my $person = Human->new( + sex => 'f', + eye_color => $set, + ); + + is( + $person->eye_color(), + $expected_color, + 'gene combination ' + . join( ',', @$set ) + . ' produces ' + . $expected_color + . ' eye color', + ); +} + +my $parent_sets = [ + [ + [qw( blue blue blue blue )], + [qw( blue blue blue blue )] => 'blue' + ], + [ + [qw( blue blue blue blue )], + [qw( brown brown green blue )] => 'brown' + ], + [ + [qw( blue blue green green )], + [qw( blue blue green green )] => 'green' + ], +]; + +foreach my $set (@$parent_sets) { + my $expected_color = pop(@$set); + + my $mother = Human->new( + sex => 'f', + eye_color => shift(@$set), + ); + + my $father = Human->new( + sex => 'm', + eye_color => shift(@$set), + ); + + my $child = $mother + $father; + + is( + $child->eye_color(), + $expected_color, + 'mother ' + . $mother->eye_color() + . ' + father ' + . $father->eye_color() + . ' = child ' + . $expected_color, + ); +} + +# Hmm, not sure how to test for random selection of genes since +# I could theoretically run an infinite number of iterations and +# never find proof that a child has inherited a particular gene. + +# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org> + +done_testing; diff --git a/t/recipes/basics_http_subtypesandcoercion.t b/t/recipes/basics_http_subtypesandcoercion.t new file mode 100644 index 0000000..f697d75 --- /dev/null +++ b/t/recipes/basics_http_subtypesandcoercion.t @@ -0,0 +1,148 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +use Test::Requires { + 'HTTP::Headers' => '0', + 'Params::Coerce' => '0', + 'URI' => '0', +}; + + + +# =begin testing SETUP +{ + + package Request; + use Moose; + use Moose::Util::TypeConstraints; + + use HTTP::Headers (); + use Params::Coerce (); + use URI (); + + subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers'); + + coerce 'My::Types::HTTP::Headers' + => from 'ArrayRef' + => via { HTTP::Headers->new( @{$_} ) } + => from 'HashRef' + => via { HTTP::Headers->new( %{$_} ) }; + + subtype 'My::Types::URI' => as class_type('URI'); + + coerce 'My::Types::URI' + => from 'Object' + => via { $_->isa('URI') + ? $_ + : Params::Coerce::coerce( 'URI', $_ ); } + => from 'Str' + => via { URI->new( $_, 'http' ) }; + + subtype 'Protocol' + => as 'Str' + => where { /^HTTP\/[0-9]\.[0-9]$/ }; + + has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'uri' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'method' => ( is => 'rw', isa => 'Str' ); + has 'protocol' => ( is => 'rw', isa => 'Protocol' ); + has 'headers' => ( + is => 'rw', + isa => 'My::Types::HTTP::Headers', + coerce => 1, + default => sub { HTTP::Headers->new } + ); +} + + + +# =begin testing +{ +my $r = Request->new; +isa_ok( $r, 'Request' ); + +{ + my $header = $r->headers; + isa_ok( $header, 'HTTP::Headers' ); + + is( $r->headers->content_type, '', + '... got no content type in the header' ); + + $r->headers( { content_type => 'text/plain' } ); + + my $header2 = $r->headers; + isa_ok( $header2, 'HTTP::Headers' ); + isnt( $header, $header2, '... created a new HTTP::Header object' ); + + is( $header2->content_type, 'text/plain', + '... got the right content type in the header' ); + + $r->headers( [ content_type => 'text/html' ] ); + + my $header3 = $r->headers; + isa_ok( $header3, 'HTTP::Headers' ); + isnt( $header2, $header3, '... created a new HTTP::Header object' ); + + is( $header3->content_type, 'text/html', + '... got the right content type in the header' ); + + $r->headers( HTTP::Headers->new( content_type => 'application/pdf' ) ); + + my $header4 = $r->headers; + isa_ok( $header4, 'HTTP::Headers' ); + isnt( $header3, $header4, '... created a new HTTP::Header object' ); + + is( $header4->content_type, 'application/pdf', + '... got the right content type in the header' ); + + isnt( + exception { + $r->headers('Foo'); + }, + undef, + '... dies when it gets bad params' + ); +} + +{ + is( $r->protocol, undef, '... got nothing by default' ); + + is( + exception { + $r->protocol('HTTP/1.0'); + }, + undef, + '... set the protocol correctly' + ); + + is( $r->protocol, 'HTTP/1.0', '... got nothing by default' ); + + isnt( + exception { + $r->protocol('http/1.0'); + }, + undef, + '... the protocol died with bar params correctly' + ); +} + +{ + $r->base('http://localhost/'); + isa_ok( $r->base, 'URI' ); + + $r->uri('http://localhost/'); + isa_ok( $r->uri, 'URI' ); +} +} + + + + +1; diff --git a/t/recipes/basics_point_attributesandsubclassing.t b/t/recipes/basics_point_attributesandsubclassing.t new file mode 100644 index 0000000..4ba63c2 --- /dev/null +++ b/t/recipes/basics_point_attributesandsubclassing.t @@ -0,0 +1,251 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Point; + use Moose; + + has 'x' => (isa => 'Int', is => 'rw', required => 1); + has 'y' => (isa => 'Int', is => 'rw', required => 1); + + sub clear { + my $self = shift; + $self->x(0); + $self->y(0); + } + + package Point3D; + use Moose; + + extends 'Point'; + + has 'z' => (isa => 'Int', is => 'rw', required => 1); + + after 'clear' => sub { + my $self = shift; + $self->z(0); + }; + + package main; + + # hash or hashrefs are ok for the constructor + my $point1 = Point->new(x => 5, y => 7); + my $point2 = Point->new({x => 5, y => 7}); + + my $point3d = Point3D->new(x => 5, y => 42, z => -5); +} + + + +# =begin testing +{ +my $point = Point->new( x => 1, y => 2 ); +isa_ok( $point, 'Point' ); +isa_ok( $point, 'Moose::Object' ); + +is( $point->x, 1, '... got the right value for x' ); +is( $point->y, 2, '... got the right value for y' ); + +$point->y(10); +is( $point->y, 10, '... got the right (changed) value for y' ); + +isnt( + exception { + $point->y('Foo'); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point->new(); + }, + undef, + '... must provide required attributes to new' +); + +$point->clear(); + +is( $point->x, 0, '... got the right (cleared) value for x' ); +is( $point->y, 0, '... got the right (cleared) value for y' ); + +# check the type constraints on the constructor + +is( + exception { + Point->new( x => 0, y => 0 ); + }, + undef, + '... can assign a 0 to x and y' +); + +isnt( + exception { + Point->new( x => 10, y => 'Foo' ); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point->new( x => 'Foo', y => 10 ); + }, + undef, + '... cannot assign a non-Int to x' +); + +# Point3D + +my $point3d = Point3D->new( { x => 10, y => 15, z => 3 } ); +isa_ok( $point3d, 'Point3D' ); +isa_ok( $point3d, 'Point' ); +isa_ok( $point3d, 'Moose::Object' ); + +is( $point3d->x, 10, '... got the right value for x' ); +is( $point3d->y, 15, '... got the right value for y' ); +is( $point3d->{'z'}, 3, '... got the right value for z' ); + +$point3d->clear(); + +is( $point3d->x, 0, '... got the right (cleared) value for x' ); +is( $point3d->y, 0, '... got the right (cleared) value for y' ); +is( $point3d->z, 0, '... got the right (cleared) value for z' ); + +isnt( + exception { + Point3D->new( x => 10, y => 'Foo', z => 3 ); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point3D->new( x => 'Foo', y => 10, z => 3 ); + }, + undef, + '... cannot assign a non-Int to x' +); + +isnt( + exception { + Point3D->new( x => 0, y => 10, z => 'Bar' ); + }, + undef, + '... cannot assign a non-Int to z' +); + +isnt( + exception { + Point3D->new( x => 10, y => 3 ); + }, + undef, + '... z is a required attribute for Point3D' +); + +# test some class introspection + +can_ok( 'Point', 'meta' ); +isa_ok( Point->meta, 'Moose::Meta::Class' ); + +can_ok( 'Point3D', 'meta' ); +isa_ok( Point3D->meta, 'Moose::Meta::Class' ); + +isnt( + Point->meta, Point3D->meta, + '... they are different metaclasses as well' +); + +# poke at Point + +is_deeply( + [ Point->meta->superclasses ], + ['Moose::Object'], + '... Point got the automagic base class' +); + +my @Point_methods = qw(meta x y clear); +my @Point_attrs = ( 'x', 'y' ); + +is_deeply( + [ sort @Point_methods ], + [ sort Point->meta->get_method_list() ], + '... we match the method list for Point' +); + +is_deeply( + [ sort @Point_attrs ], + [ sort Point->meta->get_attribute_list() ], + '... we match the attribute list for Point' +); + +foreach my $method (@Point_methods) { + ok( Point->meta->has_method($method), + '... Point has the method "' . $method . '"' ); +} + +foreach my $attr_name (@Point_attrs) { + ok( Point->meta->has_attribute($attr_name), + '... Point has the attribute "' . $attr_name . '"' ); + my $attr = Point->meta->get_attribute($attr_name); + ok( $attr->has_type_constraint, + '... Attribute ' . $attr_name . ' has a type constraint' ); + isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); + is( $attr->type_constraint->name, 'Int', + '... Attribute ' . $attr_name . ' has an Int type constraint' ); +} + +# poke at Point3D + +is_deeply( + [ Point3D->meta->superclasses ], + ['Point'], + '... Point3D gets the parent given to it' +); + +my @Point3D_methods = qw( meta z clear ); +my @Point3D_attrs = ('z'); + +is_deeply( + [ sort @Point3D_methods ], + [ sort Point3D->meta->get_method_list() ], + '... we match the method list for Point3D' +); + +is_deeply( + [ sort @Point3D_attrs ], + [ sort Point3D->meta->get_attribute_list() ], + '... we match the attribute list for Point3D' +); + +foreach my $method (@Point3D_methods) { + ok( Point3D->meta->has_method($method), + '... Point3D has the method "' . $method . '"' ); +} + +foreach my $attr_name (@Point3D_attrs) { + ok( Point3D->meta->has_attribute($attr_name), + '... Point3D has the attribute "' . $attr_name . '"' ); + my $attr = Point3D->meta->get_attribute($attr_name); + ok( $attr->has_type_constraint, + '... Attribute ' . $attr_name . ' has a type constraint' ); + isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); + is( $attr->type_constraint->name, 'Int', + '... Attribute ' . $attr_name . ' has an Int type constraint' ); +} +} + + + + +1; diff --git a/t/recipes/extending_debugging_baseclassrole.t b/t/recipes/extending_debugging_baseclassrole.t new file mode 100644 index 0000000..a05181f --- /dev/null +++ b/t/recipes/extending_debugging_baseclassrole.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +use Test::Requires 'Test::Output'; + + + +# =begin testing SETUP +{ + + package MooseX::Debugging; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + base_class_roles => ['MooseX::Debugging::Role::Object'], + ); + + package MooseX::Debugging::Role::Object; + + use Moose::Role; + + sub BUILD {} + after BUILD => sub { + my $self = shift; + + warn "Made a new " . ( ref $self ) . " object\n"; + }; +} + + + +# =begin testing +{ +{ + package Debugged; + + use Moose; + MooseX::Debugging->import; +} + +stderr_is( + sub { Debugged->new }, + "Made a new Debugged object\n", + 'got expected output from debugging role' +); +} + + + + +1; diff --git a/t/recipes/extending_mooseish_moosesugar.t b/t/recipes/extending_mooseish_moosesugar.t new file mode 100644 index 0000000..fd003c9 --- /dev/null +++ b/t/recipes/extending_mooseish_moosesugar.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Mooseish; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + with_meta => ['has_table'], + class_metaroles => { + class => ['MyApp::Meta::Class::Trait::HasTable'], + }, + ); + + sub has_table { + my $meta = shift; + $meta->table(shift); + } + + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + + has table => ( + is => 'rw', + isa => 'Str', + ); +} + + + +# =begin testing +{ +{ + package MyApp::User; + + use Moose; + MyApp::Mooseish->import; + + has_table( 'User' ); + + has( 'username' => ( is => 'ro' ) ); + has( 'password' => ( is => 'ro' ) ); + + sub login { } +} + +can_ok( MyApp::User->meta, 'table' ); +is( MyApp::User->meta->table, 'User', + 'MyApp::User->meta->table returns User' ); +ok( MyApp::User->can('username'), + 'MyApp::User has username method' ); +} + + + + +1; diff --git a/t/recipes/legacy_debugging_baseclassreplacement.t b/t/recipes/legacy_debugging_baseclassreplacement.t new file mode 100644 index 0000000..9d653c3 --- /dev/null +++ b/t/recipes/legacy_debugging_baseclassreplacement.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Base; + use Moose; + + extends 'Moose::Object'; + + before 'new' => sub { warn "Making a new " . $_[0] }; + + no Moose; + + package MyApp::UseMyBase; + use Moose (); + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + return Moose->init_meta( @_, base_class => 'MyApp::Base' ); + } +} + + + +# =begin testing SETUP +use Test::Requires 'Test::Output'; + + + +# =begin testing +{ +{ + package Foo; + + MyApp::UseMyBase->import; + + has( 'size' => ( is => 'rw' ) ); +} + +ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' ); + +ok( Foo->can('size'), 'Foo has a size method' ); + +my $foo; +stderr_like( + sub { $foo = Foo->new( size => 2 ) }, + qr/^Making a new Foo/, + 'got expected warning when calling Foo->new' +); + +is( $foo->size(), 2, '$foo->size is 2' ); +} + + + + +1; diff --git a/t/recipes/legacy_labeled_attributemetaclass.t b/t/recipes/legacy_labeled_attributemetaclass.t new file mode 100644 index 0000000..e8d93e9 --- /dev/null +++ b/t/recipes/legacy_labeled_attributemetaclass.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Attribute::Labeled; + use Moose; + extends 'Moose::Meta::Attribute'; + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package Moose::Meta::Attribute::Custom::Labeled; + sub register_implementation {'MyApp::Meta::Attribute::Labeled'} + + package MyApp::Website; + use Moose; + + has url => ( + metaclass => 'Labeled', + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->isa('MyApp::Meta::Attribute::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +} + + + +# =begin testing +{ +my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +is( + $app->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); +} + + + + +1; diff --git a/t/recipes/meta_globref_instancemetaclass.t b/t/recipes/meta_globref_instancemetaclass.t new file mode 100644 index 0000000..b02c0eb --- /dev/null +++ b/t/recipes/meta_globref_instancemetaclass.t @@ -0,0 +1,153 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package My::Meta::Instance; + + use Scalar::Util qw( weaken ); + use Symbol qw( gensym ); + + use Moose::Role; + + sub create_instance { + my $self = shift; + my $sym = gensym(); + bless $sym, $self->_class_name; + } + + sub clone_instance { + my ( $self, $instance ) = @_; + + my $new_sym = gensym(); + %{*$new_sym} = %{*$instance}; + + bless $new_sym, $self->_class_name; + } + + sub get_slot_value { + my ( $self, $instance, $slot_name ) = @_; + return *$instance->{$slot_name}; + } + + sub set_slot_value { + my ( $self, $instance, $slot_name, $value ) = @_; + *$instance->{$slot_name} = $value; + } + + sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + delete *$instance->{$slot_name}; + } + + sub is_slot_initialized { + my ( $self, $instance, $slot_name ) = @_; + exists *$instance->{$slot_name}; + } + + sub weaken_slot_value { + my ( $self, $instance, $slot_name ) = @_; + weaken *$instance->{$slot_name}; + } + + sub inline_create_instance { + my ( $self, $class_variable ) = @_; + return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }'; + } + + sub inline_slot_access { + my ( $self, $instance, $slot_name ) = @_; + return '*{' . $instance . '}->{' . $slot_name . '}'; + } + + package MyApp::User; + + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['My::Meta::Instance'], + }, + ); + + has 'name' => ( + is => 'rw', + isa => 'Str', + ); + + has 'email' => ( + is => 'rw', + isa => 'Str', + ); +} + + + +# =begin testing +{ +{ + package MyApp::Employee; + + use Moose; + extends 'MyApp::User'; + + has 'employee_number' => ( is => 'rw' ); +} + +for my $x ( 0 .. 1 ) { + MyApp::User->meta->make_immutable if $x; + + my $user = MyApp::User->new( + name => 'Faye', + email => 'faye@example.com', + ); + + ok( eval { *{$user} }, 'user object is an glob ref with some values' ); + + is( $user->name, 'Faye', 'check name' ); + is( $user->email, 'faye@example.com', 'check email' ); + + $user->name('Ralph'); + is( $user->name, 'Ralph', 'check name after changing it' ); + + $user->email('ralph@example.com'); + is( $user->email, 'ralph@example.com', 'check email after changing it' ); +} + +for my $x ( 0 .. 1 ) { + MyApp::Employee->meta->make_immutable if $x; + + my $emp = MyApp::Employee->new( + name => 'Faye', + email => 'faye@example.com', + employee_number => $x, + ); + + ok( eval { *{$emp} }, 'employee object is an glob ref with some values' ); + + is( $emp->name, 'Faye', 'check name' ); + is( $emp->email, 'faye@example.com', 'check email' ); + is( $emp->employee_number, $x, 'check employee_number' ); + + $emp->name('Ralph'); + is( $emp->name, 'Ralph', 'check name after changing it' ); + + $emp->email('ralph@example.com'); + is( $emp->email, 'ralph@example.com', 'check email after changing it' ); + + $emp->employee_number(42); + is( $emp->employee_number, 42, 'check employee_number after changing it' ); +} +} + + + + +1; diff --git a/t/recipes/meta_labeled_attributetrait.t b/t/recipes/meta_labeled_attributetrait.t new file mode 100644 index 0000000..48e3215 --- /dev/null +++ b/t/recipes/meta_labeled_attributetrait.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Attribute::Trait::Labeled; + use Moose::Role; + Moose::Util::meta_attribute_alias('Labeled'); + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package MyApp::Website; + use Moose; + + has url => ( + traits => [qw/Labeled/], + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +} + + + +# =begin testing +{ +my $app + = MyApp::Website->new( url => 'http://google.com', name => 'Google' ); +is( + $app->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); +} + + + + +1; diff --git a/t/recipes/meta_privateorpublic_methodmetaclass.t b/t/recipes/meta_privateorpublic_methodmetaclass.t new file mode 100644 index 0000000..20650c7 --- /dev/null +++ b/t/recipes/meta_privateorpublic_methodmetaclass.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Method::PrivateOrPublic; + + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Moose::Meta::Method'; + + has '_policy' => ( + is => 'ro', + isa => enum( [ qw( public private ) ] ), + default => 'public', + init_arg => 'policy', + ); + + sub new { + my $class = shift; + my %options = @_; + + my $self = $class->SUPER::wrap(%options); + + $self->{_policy} = $options{policy}; + + $self->_add_policy_wrapper; + + return $self; + } + + sub _add_policy_wrapper { + my $self = shift; + + return if $self->is_public; + + my $name = $self->name; + my $package = $self->package_name; + my $real_body = $self->body; + + my $body = sub { + die "The $package\::$name method is private" + unless ( scalar caller() ) eq $package; + + goto &{$real_body}; + }; + + $self->{body} = $body; + } + + sub is_public { $_[0]->_policy eq 'public' } + sub is_private { $_[0]->_policy eq 'private' } + + package MyApp::User; + + use Moose; + + has 'password' => ( is => 'rw' ); + + __PACKAGE__->meta()->add_method( + '_reset_password', + MyApp::Meta::Method::PrivateOrPublic->new( + name => '_reset_password', + package_name => __PACKAGE__, + body => sub { $_[0]->password('reset') }, + policy => 'private', + ) + ); +} + + + +# =begin testing +{ +package main; +use strict; +use warnings; + +use Test::Fatal; + +my $user = MyApp::User->new( password => 'foo!' ); + +like( exception { $user->_reset_password }, +qr/The MyApp::User::_reset_password method is private/, + '_reset_password method dies if called outside MyApp::User class'); + +{ + package MyApp::User; + + sub run_reset { $_[0]->_reset_password } +} + +$user->run_reset; + +is( $user->password, 'reset', 'password has been reset' ); +} + + + + +1; diff --git a/t/recipes/meta_table_metaclasstrait.t b/t/recipes/meta_table_metaclasstrait.t new file mode 100644 index 0000000..b396220 --- /dev/null +++ b/t/recipes/meta_table_metaclasstrait.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +BEGIN { + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + Moose::Util::meta_class_alias('HasTable'); + + has table => ( + is => 'rw', + isa => 'Str', + ); +} + + + +# =begin testing SETUP +{ + + # in lib/MyApp/Meta/Class/Trait/HasTable.pm + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + Moose::Util::meta_class_alias('HasTable'); + + has table => ( + is => 'rw', + isa => 'Str', + ); + + # in lib/MyApp/User.pm + package MyApp::User; + use Moose -traits => 'HasTable'; + + __PACKAGE__->meta->table('User'); +} + + + +# =begin testing +{ +can_ok( MyApp::User->meta, 'table' ); +is( MyApp::User->meta->table, 'User', 'My::User table is User' ); +} + + + + +1; diff --git a/t/recipes/roles_applicationtoinstance.t b/t/recipes/roles_applicationtoinstance.t new file mode 100644 index 0000000..53e3210 --- /dev/null +++ b/t/recipes/roles_applicationtoinstance.t @@ -0,0 +1,96 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + # Not in the recipe, but needed for writing tests. + package Employee; + + use Moose; + + has 'name' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + + has 'work' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_work', + ); +} + + + +# =begin testing SETUP +{ + + package MyApp::Role::Job::Manager; + + use List::Util qw( first ); + + use Moose::Role; + + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]', + ); + + sub assign_work { + my $self = shift; + my $work = shift; + + my $employee = first { !$_->has_work } @{ $self->employees }; + + die 'All my employees have work to do!' unless $employee; + + $employee->work($work); + } + + package main; + + my $lisa = Employee->new( name => 'Lisa' ); + MyApp::Role::Job::Manager->meta->apply($lisa); + + my $homer = Employee->new( name => 'Homer' ); + my $bart = Employee->new( name => 'Bart' ); + my $marge = Employee->new( name => 'Marge' ); + + $lisa->employees( [ $homer, $bart, $marge ] ); + $lisa->assign_work('mow the lawn'); +} + + + +# =begin testing +{ +{ + my $lisa = Employee->new( name => 'Lisa' ); + MyApp::Role::Job::Manager->meta->apply($lisa); + + my $homer = Employee->new( name => 'Homer' ); + my $bart = Employee->new( name => 'Bart' ); + my $marge = Employee->new( name => 'Marge' ); + + $lisa->employees( [ $homer, $bart, $marge ] ); + $lisa->assign_work('mow the lawn'); + + ok( $lisa->does('MyApp::Role::Job::Manager'), + 'lisa now does the manager role' ); + + is( $homer->work, 'mow the lawn', + 'homer was assigned a task by lisa' ); +} +} + + + + +1; diff --git a/t/recipes/roles_comparable_codereuse.t b/t/recipes/roles_comparable_codereuse.t new file mode 100644 index 0000000..677a8ce --- /dev/null +++ b/t/recipes/roles_comparable_codereuse.t @@ -0,0 +1,202 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Eq; + use Moose::Role; + + requires 'equal_to'; + + sub not_equal_to { + my ( $self, $other ) = @_; + not $self->equal_to($other); + } + + package Comparable; + use Moose::Role; + + with 'Eq'; + + requires 'compare'; + + sub equal_to { + my ( $self, $other ) = @_; + $self->compare($other) == 0; + } + + sub greater_than { + my ( $self, $other ) = @_; + $self->compare($other) == 1; + } + + sub less_than { + my ( $self, $other ) = @_; + $self->compare($other) == -1; + } + + sub greater_than_or_equal_to { + my ( $self, $other ) = @_; + $self->greater_than($other) || $self->equal_to($other); + } + + sub less_than_or_equal_to { + my ( $self, $other ) = @_; + $self->less_than($other) || $self->equal_to($other); + } + + package Printable; + use Moose::Role; + + requires 'to_string'; + + package US::Currency; + use Moose; + + with 'Comparable', 'Printable'; + + has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); + + sub compare { + my ( $self, $other ) = @_; + $self->amount <=> $other->amount; + } + + sub to_string { + my $self = shift; + sprintf '$%0.2f USD' => $self->amount; + } +} + + + +# =begin testing +{ +ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' ); +ok( US::Currency->does('Eq'), '... US::Currency does Eq' ); +ok( US::Currency->does('Printable'), '... US::Currency does Printable' ); + +my $hundred = US::Currency->new( amount => 100.00 ); +isa_ok( $hundred, 'US::Currency' ); + +ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" ); +ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" ); + +can_ok( $hundred, 'amount' ); +is( $hundred->amount, 100, '... got the right amount' ); + +can_ok( $hundred, 'to_string' ); +is( $hundred->to_string, '$100.00 USD', + '... got the right stringified value' ); + +ok( $hundred->does('Comparable'), '... US::Currency does Comparable' ); +ok( $hundred->does('Eq'), '... US::Currency does Eq' ); +ok( $hundred->does('Printable'), '... US::Currency does Printable' ); + +my $fifty = US::Currency->new( amount => 50.00 ); +isa_ok( $fifty, 'US::Currency' ); + +can_ok( $fifty, 'amount' ); +is( $fifty->amount, 50, '... got the right amount' ); + +can_ok( $fifty, 'to_string' ); +is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' ); + +ok( $hundred->greater_than($fifty), '... 100 gt 50' ); +ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' ); +ok( !$hundred->less_than($fifty), '... !100 lt 50' ); +ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' ); +ok( !$hundred->equal_to($fifty), '... !100 eq 50' ); +ok( $hundred->not_equal_to($fifty), '... 100 ne 50' ); + +ok( !$fifty->greater_than($hundred), '... !50 gt 100' ); +ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' ); +ok( $fifty->less_than($hundred), '... 50 lt 100' ); +ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' ); +ok( !$fifty->equal_to($hundred), '... !50 eq 100' ); +ok( $fifty->not_equal_to($hundred), '... 50 ne 100' ); + +ok( !$fifty->greater_than($fifty), '... !50 gt 50' ); +ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' ); +ok( !$fifty->less_than($fifty), '... 50 lt 50' ); +ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' ); +ok( $fifty->equal_to($fifty), '... 50 eq 50' ); +ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' ); + +## ... check some meta-stuff + +# Eq + +my $eq_meta = Eq->meta; +isa_ok( $eq_meta, 'Moose::Meta::Role' ); + +ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' ); +ok( $eq_meta->requires_method('equal_to'), + '... Eq requires_method not_equal_to' ); + +# Comparable + +my $comparable_meta = Comparable->meta; +isa_ok( $comparable_meta, 'Moose::Meta::Role' ); + +ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' ); + +foreach my $method_name ( + qw( + equal_to not_equal_to + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + ) + ) { + ok( $comparable_meta->has_method($method_name), + '... Comparable has_method ' . $method_name ); +} + +ok( $comparable_meta->requires_method('compare'), + '... Comparable requires_method compare' ); + +# Printable + +my $printable_meta = Printable->meta; +isa_ok( $printable_meta, 'Moose::Meta::Role' ); + +ok( $printable_meta->requires_method('to_string'), + '... Printable requires_method to_string' ); + +# US::Currency + +my $currency_meta = US::Currency->meta; +isa_ok( $currency_meta, 'Moose::Meta::Class' ); + +ok( $currency_meta->does_role('Comparable'), + '... US::Currency does Comparable' ); +ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' ); +ok( $currency_meta->does_role('Printable'), + '... US::Currency does Printable' ); + +foreach my $method_name ( + qw( + amount + equal_to not_equal_to + compare + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + to_string + ) + ) { + ok( $currency_meta->has_method($method_name), + '... US::Currency has_method ' . $method_name ); +} +} + + + + +1; diff --git a/t/recipes/roles_restartable_advancedcomposition.t b/t/recipes/roles_restartable_advancedcomposition.t new file mode 100644 index 0000000..8b2fdf4 --- /dev/null +++ b/t/recipes/roles_restartable_advancedcomposition.t @@ -0,0 +1,118 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Restartable; + use Moose::Role; + + has 'is_paused' => ( + is => 'rw', + isa => 'Bool', + default => 0, + ); + + requires 'save_state', 'load_state'; + + sub stop { 1 } + + sub start { 1 } + + package Restartable::ButUnreliable; + use Moose::Role; + + with 'Restartable' => { + -alias => { + stop => '_stop', + start => '_start' + }, + -excludes => [ 'stop', 'start' ], + }; + + sub stop { + my $self = shift; + + $self->explode() if rand(1) > .5; + + $self->_stop(); + } + + sub start { + my $self = shift; + + $self->explode() if rand(1) > .5; + + $self->_start(); + } + + package Restartable::ButBroken; + use Moose::Role; + + with 'Restartable' => { -excludes => [ 'stop', 'start' ] }; + + sub stop { + my $self = shift; + + $self->explode(); + } + + sub start { + my $self = shift; + + $self->explode(); + } +} + + + +# =begin testing +{ +{ + my $unreliable = Moose::Meta::Class->create_anon_class( + superclasses => [], + roles => [qw/Restartable::ButUnreliable/], + methods => { + explode => sub { }, # nop. + 'save_state' => sub { }, + 'load_state' => sub { }, + }, + )->new_object(); + ok( $unreliable, 'made anon class with Restartable::ButUnreliable role' ); + can_ok( $unreliable, qw/start stop/ ); +} + +{ + my $cnt = 0; + my $broken = Moose::Meta::Class->create_anon_class( + superclasses => [], + roles => [qw/Restartable::ButBroken/], + methods => { + explode => sub { $cnt++ }, + 'save_state' => sub { }, + 'load_state' => sub { }, + }, + )->new_object(); + + ok( $broken, 'made anon class with Restartable::ButBroken role' ); + + $broken->start(); + + is( $cnt, 1, '... start called explode' ); + + $broken->stop(); + + is( $cnt, 2, '... stop also called explode' ); +} +} + + + + +1; diff --git a/t/roles/anonymous_roles.t b/t/roles/anonymous_roles.t new file mode 100644 index 0000000..53bfb34 --- /dev/null +++ b/t/roles/anonymous_roles.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +use Class::Load qw(is_class_loaded); + +my $role = Moose::Meta::Role->create_anon_role( + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet'); +$role->apply($class); +# XXX: Moose::Util::apply_all_roles doesn't cope with references yet + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +like($role->name, qr/^Moose::Meta::Role::__ANON__::SERIAL::\d+$/, ""); +ok($role->is_anon_role, "the role knows it's anonymous"); + +ok(is_class_loaded(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded"); +ok(Class::MOP::class_of(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of"); + +{ + my $role; + { + my $meta = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $role = $meta->name; + can_ok($role, 'foo'); + } + ok(!$role->can('foo')); +} + +{ + my $role; + { + my $meta = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $role = $meta->name; + can_ok($role, 'foo'); + Class::MOP::remove_metaclass_by_name($role); + } + ok(!$role->can('foo')); +} + +done_testing; diff --git a/t/roles/application_toclass.t b/t/roles/application_toclass.t new file mode 100644 index 0000000..b07bc80 --- /dev/null +++ b/t/roles/application_toclass.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More; + +do { + package Role::Foo; + use Moose::Role; + + sub foo { } + + + package Consumer::Basic; + use Moose; + + with 'Role::Foo'; + + package Consumer::Excludes; + use Moose; + + with 'Role::Foo' => { -excludes => 'foo' }; + + package Consumer::Aliases; + use Moose; + + with 'Role::Foo' => { -alias => { 'foo' => 'role_foo' } }; + + package Consumer::Overrides; + use Moose; + + with 'Role::Foo'; + + sub foo { } +}; + +my @basic = Consumer::Basic->meta->role_applications; +my @excludes = Consumer::Excludes->meta->role_applications; +my @aliases = Consumer::Aliases->meta->role_applications; +my @overrides = Consumer::Overrides->meta->role_applications; + +is(@basic, 1); +is(@excludes, 1); +is(@aliases, 1); +is(@overrides, 1); + +my $basic = $basic[0]; +my $excludes = $excludes[0]; +my $aliases = $aliases[0]; +my $overrides = $overrides[0]; + +isa_ok($basic, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($excludes, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($aliases, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($overrides, 'Moose::Meta::Role::Application::ToClass'); + +is($basic->role, Role::Foo->meta); +is($excludes->role, Role::Foo->meta); +is($aliases->role, Role::Foo->meta); +is($overrides->role, Role::Foo->meta); + +is($basic->class, Consumer::Basic->meta); +is($excludes->class, Consumer::Excludes->meta); +is($aliases->class, Consumer::Aliases->meta); +is($overrides->class, Consumer::Overrides->meta); + +is_deeply($basic->get_method_aliases, {}); +is_deeply($excludes->get_method_aliases, {}); +is_deeply($aliases->get_method_aliases, { foo => 'role_foo' }); +is_deeply($overrides->get_method_aliases, {}); + +is_deeply($basic->get_method_exclusions, []); +is_deeply($excludes->get_method_exclusions, ['foo']); +is_deeply($aliases->get_method_exclusions, []); +is_deeply($overrides->get_method_exclusions, []); + +done_testing; diff --git a/t/roles/apply_role.t b/t/roles/apply_role.t new file mode 100644 index 0000000..d811d03 --- /dev/null +++ b/t/roles/apply_role.t @@ -0,0 +1,227 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package FooRole; + use Moose::Role; + + our $VERSION = 23; + + has 'bar' => ( is => 'rw', isa => 'FooClass' ); + has 'baz' => ( is => 'ro' ); + + sub goo {'FooRole::goo'} + sub foo {'FooRole::foo'} + + override 'boo' => sub { 'FooRole::boo -> ' . super() }; + + around 'blau' => sub { + my $c = shift; + 'FooRole::blau -> ' . $c->(); + }; +} + +{ + package BarRole; + use Moose::Role; + sub woot {'BarRole::woot'} +} + +{ + package BarClass; + use Moose; + + sub boo {'BarClass::boo'} + sub foo {'BarClass::foo'} # << the role overrides this ... +} + +{ + package FooClass; + use Moose; + + extends 'BarClass'; + + ::like( ::exception { with 'FooRole' => { -version => 42 } }, qr/FooRole version 42 required--this is only version 23/, 'applying role with unsatisfied version requirement' ); + + ::is( ::exception { with 'FooRole' => { -version => 13 } }, undef, 'applying role with satisfied version requirement' ); + + sub blau {'FooClass::blau'} # << the role wraps this ... + + sub goo {'FooClass::goo'} # << overrides the one from the role ... +} + +{ + package FooBarClass; + use Moose; + + extends 'FooClass'; + with 'FooRole', 'BarRole'; +} + +{ + package PlainJane; + sub new { return bless {}, __PACKAGE__; } +} + +my $foo_class_meta = FooClass->meta; +isa_ok( $foo_class_meta, 'Moose::Meta::Class' ); + +my $foobar_class_meta = FooBarClass->meta; +isa_ok( $foobar_class_meta, 'Moose::Meta::Class' ); + +isnt( exception { + $foo_class_meta->does_role(); +}, undef, '... does_role requires a role name' ); + +isnt( exception { + $foo_class_meta->add_role(); +}, undef, '... apply_role requires a role' ); + +isnt( exception { + $foo_class_meta->add_role( bless( {} => 'Fail' ) ); +}, undef, '... apply_role requires a role' ); + +ok( $foo_class_meta->does_role('FooRole'), + '... the FooClass->meta does_role FooRole' ); +ok( !$foo_class_meta->does_role('OtherRole'), + '... the FooClass->meta !does_role OtherRole' ); + +ok( $foobar_class_meta->does_role('FooRole'), + '... the FooBarClass->meta does_role FooRole' ); +ok( $foobar_class_meta->does_role('BarRole'), + '... the FooBarClass->meta does_role BarRole' ); +ok( !$foobar_class_meta->does_role('OtherRole'), + '... the FooBarClass->meta !does_role OtherRole' ); + +foreach my $method_name (qw(bar baz foo boo blau goo)) { + ok( $foo_class_meta->has_method($method_name), + '... FooClass has the method ' . $method_name ); + ok( $foobar_class_meta->has_method($method_name), + '... FooBarClass has the method ' . $method_name ); +} + +ok( !$foo_class_meta->has_method('woot'), + '... FooClass lacks the method woot' ); +ok( $foobar_class_meta->has_method('woot'), + '... FooBarClass has the method woot' ); + +foreach my $attr_name (qw(bar baz)) { + ok( $foo_class_meta->has_attribute($attr_name), + '... FooClass has the attribute ' . $attr_name ); + ok( $foobar_class_meta->has_attribute($attr_name), + '... FooBarClass has the attribute ' . $attr_name ); +} + +can_ok( 'FooClass', 'does' ); +ok( FooClass->does('FooRole'), '... the FooClass does FooRole' ); +ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' ); +ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' ); + +can_ok( 'FooBarClass', 'does' ); +ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' ); +ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' ); +ok( !FooBarClass->does('OtherRole'), + '... the FooBarClass does not do OtherRole' ); + +my $foo = FooClass->new(); +isa_ok( $foo, 'FooClass' ); + +my $foobar = FooBarClass->new(); +isa_ok( $foobar, 'FooBarClass' ); + +is( $foo->goo, 'FooClass::goo', '... got the right value of goo' ); +is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' ); + +is( $foo->boo, 'FooRole::boo -> BarClass::boo', + '... got the right value from ->boo' ); +is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', + '... got the right value from ->boo (double wrapped)' ); + +is( $foo->blau, 'FooRole::blau -> FooClass::blau', + '... got the right value from ->blau' ); +is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', + '... got the right value from ->blau' ); + +foreach my $foo ( $foo, $foobar ) { + can_ok( $foo, 'does' ); + ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' ); + ok( !$foo->does('OtherRole'), + '... and instance of FooClass does not do OtherRole' ); + + can_ok( $foobar, 'does' ); + ok( $foobar->does('FooRole'), + '... an instance of FooBarClass does FooRole' ); + ok( $foobar->does('BarRole'), + '... an instance of FooBarClass does BarRole' ); + ok( !$foobar->does('OtherRole'), + '... and instance of FooBarClass does not do OtherRole' ); + + for my $method (qw/bar baz foo boo goo blau/) { + can_ok( $foo, $method ); + } + + is( $foo->foo, 'FooRole::foo', '... got the right value of foo' ); + + ok( !defined( $foo->baz ), '... $foo->baz is undefined' ); + ok( !defined( $foo->bar ), '... $foo->bar is undefined' ); + + isnt( exception { + $foo->baz(1); + }, undef, '... baz is a read-only accessor' ); + + isnt( exception { + $foo->bar(1); + }, undef, '... bar is a read-write accessor with a type constraint' ); + + my $foo2 = FooClass->new(); + isa_ok( $foo2, 'FooClass' ); + + is( exception { + $foo->bar($foo2); + }, undef, '... bar is a read-write accessor with a type constraint' ); + + is( $foo->bar, $foo2, '... got the right value for bar now' ); +} + +{ + { + package MRole; + use Moose::Role; + sub meth { } + } + + { + package MRole2; + use Moose::Role; + sub meth2 { } + } + + { + use Moose::Meta::Class; + use Moose::Object; + use Moose::Util qw(apply_all_roles); + + my $class = Moose::Meta::Class->create( 'Class' => ( + superclasses => [ 'Moose::Object' ], + )); + + apply_all_roles($class, MRole->meta, MRole2->meta); + + ok(Class->can('meth'), "can meth"); + ok(Class->can('meth2'), "can meth2"); + } +} + +{ + ok(!Moose::Util::find_meta('PlainJane'), 'not initialized'); + Moose::Util::apply_all_roles('PlainJane', 'BarRole'); + ok(Moose::Util::find_meta('PlainJane'), 'initialized'); + ok(Moose::Util::find_meta('PlainJane')->does_role('BarRole'), 'does BarRole'); + my $pj = PlainJane->new(); + ok($pj->can('woot'), 'can woot'); +} + +done_testing; diff --git a/t/roles/build.t b/t/roles/build.t new file mode 100644 index 0000000..8094b90 --- /dev/null +++ b/t/roles/build.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +# this test script ensures that my idiom of: +# role: sub BUILD, after BUILD +# continues to work to run code after object initialization, whether the class +# has a BUILD method or not + +my @CALLS; + +do { + package TestRole; + use Moose::Role; + + sub BUILD { push @CALLS, 'TestRole::BUILD' } + before BUILD => sub { push @CALLS, 'TestRole::BUILD:before' }; + after BUILD => sub { push @CALLS, 'TestRole::BUILD:after' }; +}; + +do { + package ClassWithBUILD; + use Moose; + + ::stderr_is { + with 'TestRole'; + } ''; + + sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' } +}; + +do { + package ExplicitClassWithBUILD; + use Moose; + + ::stderr_is { + with 'TestRole' => { -excludes => 'BUILD' }; + } ''; + + sub BUILD { push @CALLS, 'ExplicitClassWithBUILD::BUILD' } +}; + +do { + package ClassWithoutBUILD; + use Moose; + with 'TestRole'; +}; + +{ + is_deeply([splice @CALLS], [], "no calls to BUILD yet"); + + ClassWithBUILD->new; + + is_deeply([splice @CALLS], [ + 'TestRole::BUILD:before', + 'ClassWithBUILD::BUILD', + 'TestRole::BUILD:after', + ]); + + ClassWithoutBUILD->new; + + is_deeply([splice @CALLS], [ + 'TestRole::BUILD:before', + 'TestRole::BUILD', + 'TestRole::BUILD:after', + ]); + + if (ClassWithBUILD->meta->is_mutable) { + ClassWithBUILD->meta->make_immutable; + ClassWithoutBUILD->meta->make_immutable; + redo; + } +} + +done_testing; diff --git a/t/roles/conflict_many_methods.t b/t/roles/conflict_many_methods.t new file mode 100644 index 0000000..af149d7 --- /dev/null +++ b/t/roles/conflict_many_methods.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Bomb; + use Moose::Role; + + sub fuse { } + sub explode { } + + package Spouse; + use Moose::Role; + + sub fuse { } + sub explode { } + + package Caninish; + use Moose::Role; + + sub bark { } + + package Treeve; + use Moose::Role; + + sub bark { } +} + +{ + package PracticalJoke; + use Moose; + + ::like( ::exception { + with 'Bomb', 'Spouse'; + }, qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/ ); + + ::like( ::exception { + with ( + 'Bomb', 'Spouse', + 'Caninish', 'Treeve', + ); + }, qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/ ); +} + +done_testing; diff --git a/t/roles/create_role.t b/t/roles/create_role.t new file mode 100644 index 0000000..ce70465 --- /dev/null +++ b/t/roles/create_role.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +my $role = Moose::Meta::Role->create( + 'MyItem::Role::Equipment', + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet' => + roles => ['MyItem::Role::Equipment'], +); + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +ok(!$role->is_anon_role, "the role is not anonymous"); + +my $composed_role = Moose::Meta::Role->create( + 'MyItem::Role::Equipment2', + roles => [ $role ], +); + +ok($composed_role->does_role('MyItem::Role::Equipment2'), "Role composed into role"); + +done_testing; diff --git a/t/roles/create_role_subclass.t b/t/roles/create_role_subclass.t new file mode 100644 index 0000000..c5795cb --- /dev/null +++ b/t/roles/create_role_subclass.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +do { + package My::Meta::Role; + use Moose; + extends 'Moose::Meta::Role'; + + has test_serial => ( + is => 'ro', + isa => 'Int', + default => 1, + ); + + no Moose; +}; + +my $role = My::Meta::Role->create_anon_role; +is($role->test_serial, 1, "default value for the serial attribute"); + +my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9); +is($nine_role->test_serial, 9, "parameter value for the serial attribute"); + +done_testing; diff --git a/t/roles/empty_method_modifiers_meta_bug.t b/t/roles/empty_method_modifiers_meta_bug.t new file mode 100644 index 0000000..28f9274 --- /dev/null +++ b/t/roles/empty_method_modifiers_meta_bug.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; + +# test role and class +package SomeRole; +use Moose::Role; + +requires 'foo'; + +package SomeClass; +use Moose; +has 'foo' => (is => 'rw'); +with 'SomeRole'; + +package main; + +#my $c = SomeClass->new; +#isa_ok( $c, 'SomeClass'); + +for my $modifier_type (qw[ before around after ]) { + my $get_func = "get_${modifier_type}_method_modifiers"; + my @mms = eval{ SomeRole->meta->$get_func('foo') }; + is($@, '', "$get_func for no method mods does not die"); + is(scalar(@mms),0,'is an empty list'); +} + +done_testing; diff --git a/t/roles/extending_role_attrs.t b/t/roles/extending_role_attrs.t new file mode 100644 index 0000000..d1841ab --- /dev/null +++ b/t/roles/extending_role_attrs.t @@ -0,0 +1,184 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This basically just makes sure that using +name +on role attributes works right. + +=cut + +{ + package Foo::Role; + use Moose::Role; + + has 'bar' => ( + is => 'rw', + isa => 'Int', + default => sub { 10 }, + ); + + package Foo; + use Moose; + + with 'Foo::Role'; + + ::is( ::exception { + has '+bar' => (default => sub { 100 }); + }, undef, '... extended the attribute successfully' ); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->bar, 100, '... got the extended attribute'); + + +{ + package Bar::Role; + use Moose::Role; + + has 'foo' => ( + is => 'rw', + isa => 'Str | Int', + ); + + package Bar; + use Moose; + + with 'Bar::Role'; + + ::is( ::exception { + has '+foo' => ( + isa => 'Int', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $bar = Bar->new(foo => 42); +isa_ok($bar, 'Bar'); +is($bar->foo, 42, '... got the extended attribute'); +$bar->foo(100); +is($bar->foo, 100, "... can change the attribute's value to an Int"); + +like( exception { $bar->foo("baz") }, qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Int' with value .*baz.* at / ); +is($bar->foo, 100, "... still has the old Int value"); + + +{ + package Baz::Role; + use Moose::Role; + + has 'baz' => ( + is => 'rw', + isa => 'Value', + ); + + package Baz; + use Moose; + + with 'Baz::Role'; + + ::is( ::exception { + has '+baz' => ( + isa => 'Int | ClassName', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $baz = Baz->new(baz => 99); +isa_ok($baz, 'Baz'); +is($baz->baz, 99, '... got the extended attribute'); +$baz->baz('Foo'); +is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName"); + +like( exception { $baz->baz("zonk") }, qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName\|Int' with value .*zonk.* at / ); +is_deeply($baz->baz, 'Foo', "... still has the old ClassName value"); + + +{ + package Quux::Role; + use Moose::Role; + + has 'quux' => ( + is => 'rw', + isa => 'Str | Int | Ref', + ); + + package Quux; + use Moose; + use Moose::Util::TypeConstraints; + + with 'Quux::Role'; + + subtype 'Positive' + => as 'Int' + => where { $_ > 0 }; + + ::is( ::exception { + has '+quux' => ( + isa => 'Positive | ArrayRef', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $quux = Quux->new(quux => 99); +isa_ok($quux, 'Quux'); +is($quux->quux, 99, '... got the extended attribute'); +$quux->quux(100); +is($quux->quux, 100, "... can change the attribute's value to an Int"); +$quux->quux(["hi"]); +is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef"); + +like( exception { $quux->quux("quux") }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .*quux.* at / ); +is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); + +like( exception { $quux->quux({a => 1}) }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .+ at / ); +is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); + + +{ + package Err::Role; + use Moose::Role; + + for (1..3) { + has "err$_" => ( + isa => 'Str | Int', + is => 'bare', + ); + } + + package Err; + use Moose; + + with 'Err::Role'; + + ::is( ::exception { + has '+err1' => (isa => 'Defined'); + }, undef, "can get less specific in the subclass" ); + + ::is( ::exception { + has '+err2' => (isa => 'Bool'); + }, undef, "or change the type completely" ); + + ::is( ::exception { + has '+err3' => (isa => 'Str | ArrayRef'); + }, undef, "or add new types to the union" ); +} + +{ + package Role::With::PlusAttr; + use Moose::Role; + + with 'Foo::Role'; + + ::like( ::exception { + has '+bar' => ( is => 'ro' ); + }, qr/has '\+attr' is not supported in roles/, "Test has '+attr' in roles explodes" ); +} + +done_testing; diff --git a/t/roles/free_anonymous_roles.t b/t/roles/free_anonymous_roles.t new file mode 100644 index 0000000..98ce5dc --- /dev/null +++ b/t/roles/free_anonymous_roles.t @@ -0,0 +1,62 @@ +use strict; +use warnings; +use Test::More; +use Moose (); +use Scalar::Util 'weaken'; + +my $weak; +my $name; +do { + my $anon_class; + + do { + my $role = Moose::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Moose::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed"); + +ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries"); + +do { + my $anon_class; + + do { + my $role = Moose::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + weaken => 0, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Moose::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok($weak, "the role metaclass still exists because we told it not to weaken"); + +ok($name->can('improperly_freed'), "the symbol table still exists too"); + +done_testing; diff --git a/t/roles/imported_required_method.t b/t/roles/imported_required_method.t new file mode 100644 index 0000000..4c2e080 --- /dev/null +++ b/t/roles/imported_required_method.t @@ -0,0 +1,58 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +BEGIN { + package ExportsFoo; + use Sub::Exporter -setup => { + exports => ['foo'], + }; + + sub foo { 'FOO' } + + $INC{'ExportsFoo.pm'} = 1; +} + +{ + package Foo; + use Moose::Role; + requires 'foo'; +} + +{ + package Bar; + use Moose::Role; + requires 'bar'; +} + +{ + package Class; + use Moose; + use ExportsFoo 'foo'; + + # The grossness near the end of the regex works around a bug with \Q not + # escaping \& properly with perl 5.8.x + ::like( + ::exception { with 'Foo' }, + qr/^\Q'Foo' requires the method 'foo' to be implemented by 'Class'. If you imported functions intending to use them as methods, you need to explicitly mark them as such, via Class->meta->add_method(foo => \E\\\&foo\)/, + "imported 'method' isn't seen" + ); + Class->meta->add_method(foo => \&foo); + ::is( + ::exception { with 'Foo' }, + undef, + "now it's a method" + ); + + ::like( + ::exception { with 'Bar' }, + qr/^\Q'Bar' requires the method 'bar' to be implemented by 'Class' at/, + "requirement isn't imported, so don't give the extra info in the error" + ); +} + +does_ok('Class', 'Foo'); + +done_testing; diff --git a/t/roles/meta_role.t b/t/roles/meta_role.t new file mode 100644 index 0000000..284d28b --- /dev/null +++ b/t/roles/meta_role.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role; +use Moose::Util::TypeConstraints (); + +{ + package FooRole; + + our $VERSION = '0.01'; + + sub foo { 'FooRole::foo' } +} + +my $foo_role = Moose::Meta::Role->initialize('FooRole'); +isa_ok($foo_role, 'Moose::Meta::Role'); +isa_ok($foo_role, 'Class::MOP::Module'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); + +isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); + +is_deeply( + [ $foo_role->get_method_list() ], + [ 'foo' ], + '... got the right method list'); + +# attributes ... + +is_deeply( + [ $foo_role->get_attribute_list() ], + [], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); + +is( exception { + $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo')); +}, undef, '... added the bar attribute okay' ); + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'bar' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +my $bar = $foo_role->get_attribute('bar'); +is_deeply( $bar->original_options, { is => 'rw', isa => 'Foo' }, + 'original options for bar attribute' ); +my $bar_for_class = $bar->attribute_for_class('Moose::Meta::Attribute'); +is( + $bar_for_class->type_constraint, + Moose::Util::TypeConstraints::class_type('Foo'), + 'bar has a Foo class type' +); + +is( exception { + $foo_role->add_attribute('baz' => (is => 'ro')); +}, undef, '... added the baz attribute okay' ); + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +my $baz = $foo_role->get_attribute('baz'); +is_deeply( $baz->original_options, { is => 'ro' }, + 'original options for baz attribute' ); + +is( exception { + $foo_role->remove_attribute('bar'); +}, undef, '... removed the bar attribute okay' ); + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'baz' ], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); +ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute'); + +# method modifiers + +ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier'); + +my $method = sub { "FooRole::boo:before" }; +is( exception { + $foo_role->add_before_method_modifier('boo' => $method); +}, undef, '... added a method modifier okay' ); + +ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); +is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); + +done_testing; diff --git a/t/roles/method_aliasing_in_composition.t b/t/roles/method_aliasing_in_composition.t new file mode 100644 index 0000000..c94fad9 --- /dev/null +++ b/t/roles/method_aliasing_in_composition.t @@ -0,0 +1,206 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + requires 'role_bar'; + + package My::Class; + use Moose; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); + + package My::Class::Failure; + use Moose; + + ::like( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds' ); + + sub role_bar { 'FAIL' } +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz bar role_bar); + +{ + package My::OtherRole; + use Moose::Role; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); + + sub bar { 'My::OtherRole::bar' } + + package My::OtherRole::Failure; + use Moose::Role; + + ::like( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, qr/Cannot create a method alias if a local method of the same name exists/, '... cannot alias to a name that exists' ); + + sub role_bar { 'FAIL' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); +ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); +ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required'); + +{ + package My::AliasingRole; + use Moose::Role; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); +} + +ok(My::AliasingRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); +ok(!My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is not required'); + +{ + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + + package My::Foo::Class; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); + + package My::Foo::Class::Broken; + use Moose; + + ::like( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); +} + +{ + my $foo = My::Foo::Class->new; + isa_ok($foo, 'My::Foo::Class'); + can_ok($foo, $_) for qw/foo foo_foo bar_foo/; + is($foo->foo, 'Baz::Role::foo', '... got the right method'); + is($foo->foo_foo, 'Foo::Role::foo', '... got the right method'); + is($foo->bar_foo, 'Bar::Role::foo', '... got the right method'); +} + +{ + package My::Foo::Role; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::Role->meta->has_method($_), "we have a $_ method") for qw/foo foo_foo bar_foo/;; +ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); + + +{ + package My::Foo::Role::Other; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method"); +ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required'); + +{ + package My::Foo::AliasOnly; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } }, + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::AliasOnly->meta->has_method('foo'), 'we have a foo method'); +ok(My::Foo::AliasOnly->meta->has_method('foo_foo'), '.. and the aliased foo_foo method'); + +{ + package Role::Foo; + use Moose::Role; + + sub x1 {} + sub y1 {} +} + +{ + package Role::Bar; + use Moose::Role; + + ::is( ::exception { + with 'Role::Foo' => { + -alias => { x1 => 'foo_x1' }, + -excludes => ['y1'], + }; + }, undef, 'Compose Role::Foo into Role::Bar with alias and exclude' ); + + sub x1 {} + sub y1 {} +} + +{ + my $bar = Role::Bar->meta; + ok( $bar->has_method($_), "has $_ method" ) + for qw( x1 y1 foo_x1 ); +} + +{ + package Role::Baz; + use Moose::Role; + + ::is( ::exception { + with 'Role::Foo' => { + -alias => { x1 => 'foo_x1' }, + -excludes => ['y1'], + }; + }, undef, 'Compose Role::Foo into Role::Baz with alias and exclude' ); +} + +{ + my $baz = Role::Baz->meta; + ok( $baz->has_method($_), "has $_ method" ) + for qw( x1 foo_x1 ); + ok( ! $baz->has_method('y1'), 'Role::Baz has no y1 method' ); +} + +done_testing; diff --git a/t/roles/method_exclusion_in_composition.t b/t/roles/method_exclusion_in_composition.t new file mode 100644 index 0000000..ce7e233 --- /dev/null +++ b/t/roles/method_exclusion_in_composition.t @@ -0,0 +1,110 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package My::Class; + use Moose; + + with 'My::Role' => { -excludes => 'bar' }; +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz); +ok(!My::Class->meta->has_method('bar'), '... but we excluded bar'); + +{ + package My::OtherRole; + use Moose::Role; + + with 'My::Role' => { -excludes => 'foo' }; + + sub foo { 'My::OtherRole::foo' } + sub bar { 'My::OtherRole::bar' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar baz); + +ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required'); +ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); + +{ + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + + package My::Foo::Class; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -excludes => 'foo' }, + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); + + package My::Foo::Class::Broken; + use Moose; + + ::like( ::exception { + with 'Foo::Role', + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); +} + +{ + my $foo = My::Foo::Class->new; + isa_ok($foo, 'My::Foo::Class'); + can_ok($foo, 'foo'); + is($foo->foo, 'Baz::Role::foo', '... got the right method'); +} + +{ + package My::Foo::Role; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -excludes => 'foo' }, + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::Role->meta->has_method('foo'), "we have a foo method"); +ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); + +{ + package My::Foo::Role::Other; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role', + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(!My::Foo::Role::Other->meta->has_method('foo'), "we dont have a foo method"); +ok(My::Foo::Role::Other->meta->requires_method('foo'), '... and the &foo method is required'); + +done_testing; diff --git a/t/roles/method_modifiers.t b/t/roles/method_modifiers.t new file mode 100644 index 0000000..b3076a6 --- /dev/null +++ b/t/roles/method_modifiers.t @@ -0,0 +1,89 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +my $FooRole; +{ + package Foo::Role; + use Moose::Role; + after foo => sub { $FooRole++ }; +} + +{ + package Foo; + use Moose; + with 'Foo::Role'; + sub foo { } +} + +Foo->foo; +is($FooRole, 1, "modifier called"); + +my $BarRole; +{ + package Bar::Role; + use Moose::Role; + after ['foo', 'bar'] => sub { $BarRole++ }; +} + +{ + package Bar; + use Moose; + with 'Bar::Role'; + sub foo { } + sub bar { } +} + +Bar->foo; +is($BarRole, 1, "modifier called"); +Bar->bar; +is($BarRole, 2, "modifier called"); + +my $BazRole; +{ + package Baz::Role; + use Moose::Role; + after 'foo', 'bar' => sub { $BazRole++ }; +} + +{ + package Baz; + use Moose; + with 'Baz::Role'; + sub foo { } + sub bar { } +} + +Baz->foo; +is($BazRole, 1, "modifier called"); +Baz->bar; +is($BazRole, 2, "modifier called"); + +my $QuuxRole; +{ + package Quux::Role; + use Moose::Role; + { our $TODO; local $TODO = "can't handle regexes yet"; + ::is( ::exception { + after qr/foo|bar/ => sub { $QuuxRole++ } + }, undef ); + } +} + +{ + package Quux; + use Moose; + with 'Quux::Role'; + sub foo { } + sub bar { } +} + +{ local $TODO = "can't handle regexes yet"; +Quux->foo; +is($QuuxRole, 1, "modifier called"); +Quux->bar; +is($QuuxRole, 2, "modifier called"); +} + +done_testing; diff --git a/t/roles/methods.t b/t/roles/methods.t new file mode 100644 index 0000000..b401d1c --- /dev/null +++ b/t/roles/methods.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Role (); + +my $test1 = Moose::Meta::Role->create_anon_role; +$test1->add_method( 'foo1', sub { } ); + +ok( $test1->has_method('foo1'), 'anon role has a foo1 method' ); + +my $t1_am = $test1->get_method('foo1')->associated_metaclass; + +ok( $t1_am, 'associated_metaclass is defined' ); + +isa_ok( + $t1_am, 'Moose::Meta::Role', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Moose::Role; + + sub foo2 { } +} + +ok( Test2->meta->has_method('foo2'), 'Test2 role has a foo2 method' ); + +my $t2_am = Test2->meta->get_method('foo2')->associated_metaclass; + +ok( $t2_am, 'associated_metaclass is defined' ); + +isa_ok( + $t2_am, 'Moose::Meta::Role', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); + +done_testing; diff --git a/t/roles/more_alias_and_exclude.t b/t/roles/more_alias_and_exclude.t new file mode 100644 index 0000000..18b0f18 --- /dev/null +++ b/t/roles/more_alias_and_exclude.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + sub gorch { 'Foo::gorch' } + + package Bar; + use Moose::Role; + + sub foo { 'Bar::foo' } + sub bar { 'Bar::bar' } + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Baz; + use Moose::Role; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub baz { 'Baz::baz' } + sub gorch { 'Baz::gorch' } + + package Gorch; + use Moose::Role; + + sub foo { 'Gorch::foo' } + sub bar { 'Gorch::bar' } + sub baz { 'Gorch::baz' } + sub gorch { 'Gorch::gorch' } +} + +{ + package My::Class; + use Moose; + + ::is( ::exception { + with 'Foo' => { -excludes => [qw/bar baz gorch/], -alias => { gorch => 'foo_gorch' } }, + 'Bar' => { -excludes => [qw/foo baz gorch/] }, + 'Baz' => { -excludes => [qw/foo bar gorch/], -alias => { foo => 'baz_foo', bar => 'baz_bar' } }, + 'Gorch' => { -excludes => [qw/foo bar baz/] }; + }, undef, '... everything works out all right' ); +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +is($c->foo, 'Foo::foo', '... got the right method'); +is($c->bar, 'Bar::bar', '... got the right method'); +is($c->baz, 'Baz::baz', '... got the right method'); +is($c->gorch, 'Gorch::gorch', '... got the right method'); + +is($c->foo_gorch, 'Foo::gorch', '... got the right method'); +is($c->baz_foo, 'Baz::foo', '... got the right method'); +is($c->baz_bar, 'Baz::bar', '... got the right method'); + +{ + package Splunk; + + use Moose::Role; + + sub baz { 'Splunk::baz' } + sub gorch { 'Splunk::gorch' } + + ::is(::exception { with 'Foo' }, undef, 'role to role application works'); + + package My::Class2; + + use Moose; + + ::is(::exception { with 'Splunk' }, undef, 'and the role can be consumed'); +} + +is(My::Class2->foo, 'Foo::foo', '... got the right method'); +is(My::Class2->bar, 'Foo::bar', '... got the right method'); +is(My::Class2->baz, 'Splunk::baz', '... got the right method'); +is(My::Class2->gorch, 'Splunk::gorch', '... got the right method'); + +done_testing; diff --git a/t/roles/more_role_edge_cases.t b/t/roles/more_role_edge_cases.t new file mode 100644 index 0000000..870c09f --- /dev/null +++ b/t/roles/more_role_edge_cases.t @@ -0,0 +1,255 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + # NOTE: + # this tests that repeated role + # composition will not cause + # a conflict between two methods + # which are actually the same anyway + + { + package RootA; + use Moose::Role; + + sub foo { "RootA::foo" } + + package SubAA; + use Moose::Role; + + with "RootA"; + + sub bar { "SubAA::bar" } + + package SubAB; + use Moose; + + ::is( ::exception { + with "SubAA", "RootA"; + }, undef, '... role was composed as expected' ); + } + + ok( SubAB->does("SubAA"), "does SubAA"); + ok( SubAB->does("RootA"), "does RootA"); + + isa_ok( my $i = SubAB->new, "SubAB" ); + + can_ok( $i, "bar" ); + is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); + + can_ok( $i, "foo" ); + my $foo_rv; + is( exception { + $foo_rv = $i->foo; + }, undef, '... called foo successfully' ); + is($foo_rv, "RootA::foo", "... got the right foo rv"); +} + +{ + # NOTE: + # this edge cases shows the application of + # an after modifier over a method which + # was added during role composotion. + # The way this will work is as follows: + # role SubBA will consume RootB and + # get a local copy of RootB::foo, it + # will also store a deferred after modifier + # to be applied to whatever class SubBA is + # composed into. + # When class SubBB comsumed role SubBA, the + # RootB::foo method is added to SubBB, then + # the deferred after modifier from SubBA is + # applied to it. + # It is important to note that the application + # of the after modifier does not happen until + # role SubBA is composed into SubAA. + + { + package RootB; + use Moose::Role; + + sub foo { "RootB::foo" } + + package SubBA; + use Moose::Role; + + with "RootB"; + + has counter => ( + isa => "Num", + is => "rw", + default => 0, + ); + + after foo => sub { + $_[0]->counter( $_[0]->counter + 1 ); + }; + + package SubBB; + use Moose; + + ::is( ::exception { + with "SubBA"; + }, undef, '... composed the role successfully' ); + } + + ok( SubBB->does("SubBA"), "BB does SubBA" ); + ok( SubBB->does("RootB"), "BB does RootB" ); + + isa_ok( my $i = SubBB->new, "SubBB" ); + + can_ok( $i, "foo" ); + + my $foo_rv; + is( exception { + $foo_rv = $i->foo + }, undef, '... called foo successfully' ); + is( $foo_rv, "RootB::foo", "foo rv" ); + is( $i->counter, 1, "after hook called" ); + + is( exception { $i->foo }, undef, '... called foo successfully (again)' ); + is( $i->counter, 2, "after hook called (again)" ); + + ok(SubBA->meta->has_method('foo'), '... this has the foo method'); + #my $subba_foo_rv; + #lives_ok { + # $subba_foo_rv = SubBA::foo(); + #} '... called the sub as a function correctly'; + #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); +} + +{ + # NOTE: + # this checks that an override method + # does not try to trample over a locally + # composed in method. In this case the + # RootC::foo, which is composed into + # SubCA cannot be trampled with an + # override of 'foo' + { + package RootC; + use Moose::Role; + + sub foo { "RootC::foo" } + + package SubCA; + use Moose::Role; + + with "RootC"; + + ::isnt( ::exception { + override foo => sub { "overridden" }; + }, undef, '... cannot compose an override over a local method' ); + } +} + +# NOTE: +# need to talk to Yuval about the motivation behind +# this test, I am not sure we are testing anything +# useful here (although more tests cant hurt) + +{ + use List::Util qw/shuffle/; + + { + package Abstract; + use Moose::Role; + + requires "method"; + requires "other"; + + sub another { "abstract" } + + package ConcreteA; + use Moose::Role; + with "Abstract"; + + sub other { "concrete a" } + + package ConcreteB; + use Moose::Role; + with "Abstract"; + + sub method { "concrete b" } + + package ConcreteC; + use Moose::Role; + with "ConcreteA"; + + # NOTE: + # this was originally override, but + # that wont work (see above set of tests) + # so I switched it to around. + # However, this may not be testing the + # same thing that was originally intended + around other => sub { + return ( (shift)->() . " + c" ); + }; + + package SimpleClassWithSome; + use Moose; + + eval { with ::shuffle qw/ConcreteA ConcreteB/ }; + ::ok( !$@, "simple composition without abstract" ) || ::diag $@; + + package SimpleClassWithAll; + use Moose; + + eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; + ::ok( !$@, "simple composition with abstract" ) || ::diag $@; + } + + foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { + foreach my $role (qw/Abstract ConcreteA ConcreteB/) { + ok( $class->does($role), "$class does $role"); + } + + foreach my $method (qw/method other another/) { + can_ok( $class, $method ); + } + + is( eval { $class->another }, "abstract", "provided by abstract" ); + is( eval { $class->other }, "concrete a", "provided by concrete a" ); + is( eval { $class->method }, "concrete b", "provided by concrete b" ); + } + + { + package ClassWithSome; + use Moose; + + eval { with ::shuffle qw/ConcreteC ConcreteB/ }; + ::ok( !$@, "composition without abstract" ) || ::diag $@; + + package ClassWithAll; + use Moose; + + eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; + ::ok( !$@, "composition with abstract" ) || ::diag $@; + + package ClassWithEverything; + use Moose; + + eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash + ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); + } + + foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { + foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { + ok( $class->does($role), "$class does $role"); + } + + foreach my $method (qw/method other another/) { + can_ok( $class, $method ); + } + + is( eval { $class->another }, "abstract", "provided by abstract" ); + is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); + is( eval { $class->method }, "concrete b", "provided by concrete b" ); + } +} + +done_testing; diff --git a/t/roles/new_meta_role.t b/t/roles/new_meta_role.t new file mode 100644 index 0000000..964c3eb --- /dev/null +++ b/t/roles/new_meta_role.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +do { + package My::Meta::Role; + use Moose; + BEGIN { extends 'Moose::Meta::Role' }; +}; + +do { + package My::Role; + use Moose::Role -metaclass => 'My::Meta::Role'; +}; + +is(My::Role->meta->meta->name, 'My::Meta::Role'); + +done_testing; diff --git a/t/roles/overloading_combine_to_class.t b/t/roles/overloading_combine_to_class.t new file mode 100644 index 0000000..e749248 --- /dev/null +++ b/t/roles/overloading_combine_to_class.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 0.96; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::CombiningClass; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleWithoutOverloads )) { + + ok( + Overloading::CombiningClass->DOES($role), + "Overloading::CombiningClass does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::CombiningClass +); + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +OverloadingTests::test_overloading_for_package( + 'Overloading::CombiningClass'); + +done_testing(); diff --git a/t/roles/overloading_combine_to_instance.t b/t/roles/overloading_combine_to_instance.t new file mode 100644 index 0000000..73c4ebf --- /dev/null +++ b/t/roles/overloading_combine_to_instance.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::RoleWithOverloads; +use Overloading::RoleWithoutOverloads; + +{ + package MyClass; + use Moose; +} + +my $object = MyClass->new; + +Moose::Meta::Role->combine( + [ 'Overloading::RoleWithOverloads' => undef ], + [ 'Overloading::RoleWithoutOverloads' => undef ], +)->apply($object); + +OverloadingTests::test_overloading_for_package($_) + for 'Overloading::RoleWithOverloads', ref $object; + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +$object->message('foo'); + +OverloadingTests::test_overloading_for_object( + $object, + 'object with Overloading::RoleWithOverloads and Overloading::RoleWithoutOverloads combined and applied to instance' +); + +done_testing(); diff --git a/t/roles/overloading_combine_to_role.t b/t/roles/overloading_combine_to_role.t new file mode 100644 index 0000000..72eb9c4 --- /dev/null +++ b/t/roles/overloading_combine_to_role.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassWithCombiningRole; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleWithoutOverloads )) { + + ok( + Overloading::ClassWithCombiningRole->DOES($role), + "Overloading::ClassWithCombiningRole does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::ClassWithCombiningRole +); + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +OverloadingTests::test_overloading_for_package( + 'Overloading::ClassWithCombiningRole'); + +done_testing(); diff --git a/t/roles/overloading_composition_errors.t b/t/roles/overloading_composition_errors.t new file mode 100644 index 0000000..75e79ca --- /dev/null +++ b/t/roles/overloading_composition_errors.t @@ -0,0 +1,156 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Fatal; +use Test::Warnings; + +use lib 't/lib'; + +{ + package Role::HasFallback; + use Moose::Role; + + use overload + q{""} => '_stringify', + fallback => 1; + + sub _stringify { __PACKAGE__ } +} + +{ + package Role::NoFallback; + use Moose::Role; + + use overload + '0+' => '_numify', + fallback => 0; + + sub _numify { 42 } +} + +{ + package Class1; + use Moose; + ::like( + ::exception { with qw( Role::HasFallback Role::NoFallback ) }, + qr/\QWe have encountered an overloading conflict for the fallback during composition. This is a fatal error./, + 'exception from fallback conflict during role summation' + ); +} + +{ + package Role::NoOverloading; + use Moose::Role; + + sub foo { 42 } +} + +{ + package Class2; + use Moose; + ::like( + ::exception { with qw( Role::HasFallback Role::NoFallback Role::NoOverloading ) }, + qr/\QWe have encountered an overloading conflict for the fallback during composition. This is a fatal error./, + 'exception from fallback conflict during role summation including role without overloading' + ); +} + +{ + package Role::StringifiesViaSubref1; + use Moose::Role; + + use overload q{""} => sub { 'foo' }; +} + +{ + package Role::StringifiesViaSubref2; + use Moose::Role; + + use overload q{""} => sub { 'bar' }; +} + +{ + package Class3; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaSubref1 Role::StringifiesViaSubref2 ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different subref overloading conflict during role summation' + ); +} + +{ + package Class4; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaSubref1 Role::StringifiesViaSubref2 Role::NoOverloading ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different subref overloading conflict during role summation including role without overloading' + ); +} + +{ + package Role::StringifiesViaMethod1; + use Moose::Role; + + use overload q{""} => '_stringify1'; + sub _stringify1 { 'foo' } +} + +{ + package Role::StringifiesViaMethod2; + use Moose::Role; + + use overload q{""} => '_stringify2'; + sub _stringify2 { 'foo' } +} + +{ + package Class5; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaMethod1 Role::StringifiesViaMethod2 ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different method overloading conflict during role summation' + ); +} + +{ + package Class6; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaMethod1 Role::StringifiesViaMethod2 Role::NoOverloading ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different method overloading conflict during role summation including role without overloading' + ); +} + +{ + { + package R1; + use Moose::Role; + + use overload '&{}' => 'as_code'; + + sub as_code { } + } + + { + package R2; + use Moose::Role; + with 'R1'; + } + + { + package C1; + use Moose; + ::is( + ::exception { with 'R1', 'R2' }, + undef, + 'no conflict when class consumes multiple roles with the same overloading' + ); + } +} + +done_testing(); diff --git a/t/roles/overloading_remove_attributes_bug.t b/t/roles/overloading_remove_attributes_bug.t new file mode 100644 index 0000000..15f6cc9 --- /dev/null +++ b/t/roles/overloading_remove_attributes_bug.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; + +use lib 't/lib'; + +use OverloadingTests; + +{ + package MyRole; + use Moose::Role; + + has foo => ( is => 'ro' ); + + # Note ordering here. If metaclass reinitialization nukes attributes, this + # breaks. + with 'Overloading::RoleWithOverloads'; +} + +{ + package MyClass; + use Moose; + + with 'MyRole'; +} + +my $object = MyClass->new( foo => 21, message => 'foo' ); + +OverloadingTests::test_overloading_for_object( $object, 'MyClass object' ); + +is( $object->foo(), 21, + 'foo attribute in MyClass is still present (from MyRole)' ); + +done_testing(); diff --git a/t/roles/overloading_to_class.t b/t/roles/overloading_to_class.t new file mode 100644 index 0000000..16972a7 --- /dev/null +++ b/t/roles/overloading_to_class.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassWithOneRole; + +ok( + Overloading::ClassWithOneRole->DOES('Overloading::RoleWithOverloads'), + 'Overloading::ClassWithOneRole consumed Overloading::RoleWithOverloads', +); + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::ClassWithOneRole +); + +OverloadingTests::test_overloading_for_object( + 'Overloading::ClassWithOneRole'); + +{ + package Role1; + use Moose::Role; + use overload + q{""} => '_role1_stringify', + q{+} => '_role1_plus', + fallback => 0; + sub _role1_stringify {__PACKAGE__} + sub _role1_plus {42} +} + +{ + package Class1; + use Moose; + use overload + q{""} => '_class1_stringify', + fallback => 1; + with 'Role1'; + sub _class1_stringify {__PACKAGE__} +} + +is( + Class1->meta->get_overload_fallback_value, + 1, + 'fallback setting for class overrides setting in composed role' +); + +is( + Class1->new . q{}, + 'Class1', + 'overload method for class overrides method in composed role' +); + +my $overload = Class1->meta->get_overloaded_operator(q{+}); +is( + $overload->original_overload->associated_metaclass->name, + 'Role1', + '+ overloading for Class1 originally came from Role1' +); + +done_testing(); diff --git a/t/roles/overloading_to_instance.t b/t/roles/overloading_to_instance.t new file mode 100644 index 0000000..7edbc22 --- /dev/null +++ b/t/roles/overloading_to_instance.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::RoleWithOverloads; + +{ + package MyClass; + use Moose; +} + +my $object = MyClass->new; +Overloading::RoleWithOverloads->meta->apply($object); + +OverloadingTests::test_overloading_for_package($_) + for 'Overloading::RoleWithOverloads', ref $object; + +$object->message('foo'); + +OverloadingTests::test_overloading_for_object( + $object, + 'object with Overloading::RoleWithOverloads applied to instance' +); + +done_testing(); diff --git a/t/roles/overloading_to_role.t b/t/roles/overloading_to_role.t new file mode 100644 index 0000000..f0fa326 --- /dev/null +++ b/t/roles/overloading_to_role.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassConsumesRoleConsumesOverloads; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleConsumesOverloads )) { + + ok( + Overloading::ClassConsumesRoleConsumesOverloads->DOES($role), + "Overloading::ClassConsumesRoleConsumesOverloads does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::RoleConsumesOverloads + Overloading::ClassConsumesRoleConsumesOverloads +); + +OverloadingTests::test_overloading_for_object( + 'Overloading::ClassConsumesRoleConsumesOverloads'); + +# These tests failed on 5.18+ in MXRWO - the key issue was the lack of a +# "fallback" key being passed to overload.pm +{ + package MyRole1; + use Moose::Role; + use overload q{""} => '_stringify'; + sub _stringify {__PACKAGE__} +} + +{ + package MyRole2; + use Moose::Role; + with 'MyRole1'; +} + +{ + package Class1; + use Moose; + with 'MyRole2'; +} + +is( + Class1->new . q{}, + 'MyRole1', + 'stringification overloading is passed through all roles' +); + +done_testing(); diff --git a/t/roles/overriding.t b/t/roles/overriding.t new file mode 100644 index 0000000..dbaa443 --- /dev/null +++ b/t/roles/overriding.t @@ -0,0 +1,214 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + # test no conflicts here + package Role::A; + use Moose::Role; + + sub bar { 'Role::A::bar' } + + package Role::B; + use Moose::Role; + + sub xxy { 'Role::B::xxy' } + + package Role::C; + use Moose::Role; + + ::is( ::exception { + with qw(Role::A Role::B); # no conflict here + }, undef, "define role C" ); + + sub foo { 'Role::C::foo' } + sub zot { 'Role::C::zot' } + + package Class::A; + use Moose; + + ::is( ::exception { + with qw(Role::C); + }, undef, "define class A" ); + + sub zot { 'Class::A::zot' } +} + +can_ok( Class::A->new, qw(foo bar xxy zot) ); + +is( Class::A->new->foo, "Role::C::foo", "... got the right foo method" ); +is( Class::A->new->zot, "Class::A::zot", "... got the right zot method" ); +is( Class::A->new->bar, "Role::A::bar", "... got the right bar method" ); +is( Class::A->new->xxy, "Role::B::xxy", "... got the right xxy method" ); + +{ + # check that when a role is added to another role + # that the consumer's method shadows just like for classes. + + package Role::A::Shadow; + use Moose::Role; + + with 'Role::A'; + + sub bar { 'Role::A::Shadow::bar' } + + package Class::A::Shadow; + use Moose; + + ::is( ::exception { + with 'Role::A::Shadow'; + }, undef, '... did fufill the requirement of &bar method' ); +} + +can_ok( Class::A::Shadow->new, qw(bar) ); + +is( Class::A::Shadow->new->bar, 'Role::A::Shadow::bar', "... got the right bar method" ); + +{ + # check that when two roles are composed, they conflict + # but the composing role can resolve that conflict + + package Role::D; + use Moose::Role; + + sub foo { 'Role::D::foo' } + sub bar { 'Role::D::bar' } + + package Role::E; + use Moose::Role; + + sub foo { 'Role::E::foo' } + sub xxy { 'Role::E::xxy' } + + package Role::F; + use Moose::Role; + + ::is( ::exception { + with qw(Role::D Role::E); # conflict between 'foo's here + }, undef, "define role Role::F" ); + + sub foo { 'Role::F::foo' } + sub zot { 'Role::F::zot' } + + package Class::B; + use Moose; + + ::is( ::exception { + with qw(Role::F); + }, undef, "define class Class::B" ); + + sub zot { 'Class::B::zot' } +} + +can_ok( Class::B->new, qw(foo bar xxy zot) ); + +is( Class::B->new->foo, "Role::F::foo", "... got the &foo method okay" ); +is( Class::B->new->zot, "Class::B::zot", "... got the &zot method okay" ); +is( Class::B->new->bar, "Role::D::bar", "... got the &bar method okay" ); +is( Class::B->new->xxy, "Role::E::xxy", "... got the &xxy method okay" ); + +ok(!Role::F->meta->requires_method('foo'), '... Role::F fufilled the &foo requirement'); + +{ + # check that a conflict can be resolved + # by a role, but also new ones can be + # created just as easily ... + + package Role::D::And::E::NoConflict; + use Moose::Role; + + ::is( ::exception { + with qw(Role::D Role::E); # conflict between 'foo's here + }, undef, "... define role Role::D::And::E::NoConflict" ); + + sub foo { 'Role::D::And::E::NoConflict::foo' } # this overrides ... + + sub xxy { 'Role::D::And::E::NoConflict::xxy' } # and so do these ... + sub bar { 'Role::D::And::E::NoConflict::bar' } + +} + +ok(!Role::D::And::E::NoConflict->meta->requires_method('foo'), '... Role::D::And::E::NoConflict fufilled the &foo requirement'); +ok(!Role::D::And::E::NoConflict->meta->requires_method('xxy'), '... Role::D::And::E::NoConflict fulfilled the &xxy requirement'); +ok(!Role::D::And::E::NoConflict->meta->requires_method('bar'), '... Role::D::And::E::NoConflict fulfilled the &bar requirement'); + +{ + # conflict propagation + + package Role::H; + use Moose::Role; + + sub foo { 'Role::H::foo' } + sub bar { 'Role::H::bar' } + + package Role::J; + use Moose::Role; + + sub foo { 'Role::J::foo' } + sub xxy { 'Role::J::xxy' } + + package Role::I; + use Moose::Role; + + ::is( ::exception { + with qw(Role::J Role::H); # conflict between 'foo's here + }, undef, "define role Role::I" ); + + sub zot { 'Role::I::zot' } + sub zzy { 'Role::I::zzy' } + + package Class::C; + use Moose; + + ::like( ::exception { + with qw(Role::I); + }, qr/Due to a method name conflict in roles 'Role::H' and 'Role::J', the method 'foo' must be implemented or excluded by 'Class::C'/, "defining class Class::C fails" ); + + sub zot { 'Class::C::zot' } + + package Class::E; + use Moose; + + ::is( ::exception { + with qw(Role::I); + }, undef, "resolved with method" ); + + sub foo { 'Class::E::foo' } + sub zot { 'Class::E::zot' } +} + +can_ok( Class::E->new, qw(foo bar xxy zot) ); + +is( Class::E->new->foo, "Class::E::foo", "... got the right &foo method" ); +is( Class::E->new->zot, "Class::E::zot", "... got the right &zot method" ); +is( Class::E->new->bar, "Role::H::bar", "... got the right &bar method" ); +is( Class::E->new->xxy, "Role::J::xxy", "... got the right &xxy method" ); + +ok(Role::I->meta->requires_method('foo'), '... Role::I still have the &foo requirement'); + +{ + is( exception { + package Class::D; + use Moose; + + has foo => ( default => __PACKAGE__ . "::foo", is => "rw" ); + + sub zot { 'Class::D::zot' } + + with qw(Role::I); + + }, undef, "resolved with attr" ); + + can_ok( Class::D->new, qw(foo bar xxy zot) ); + is( eval { Class::D->new->bar }, "Role::H::bar", "bar" ); + is( eval { Class::D->new->zzy }, "Role::I::zzy", "zzy" ); + + is( eval { Class::D->new->foo }, "Class::D::foo", "foo" ); + is( eval { Class::D->new->zot }, "Class::D::zot", "zot" ); + +} + +done_testing; diff --git a/t/roles/reinitialize_anon_role.t b/t/roles/reinitialize_anon_role.t new file mode 100644 index 0000000..2554f2e --- /dev/null +++ b/t/roles/reinitialize_anon_role.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +{ + package Role::Metarole; + use Moose::Role; +} + +my ($role2); +{ + my $role1 = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { }, + }, + ); + ok($role1->has_method('foo'), "role has method foo"); + $role2 = Moose::Util::MetaRole::apply_metaroles( + for => $role1->name, + role_metaroles => { role => ['Role::Metarole'] }, + ); + isnt($role1, $role2, "anon role was reinitialized"); + is($role1->name, $role2->name, "but it's the same anon role"); + is_deeply([sort $role2->get_method_list], ['foo', 'meta'], + "has the right methods"); +} +is_deeply([sort $role2->get_method_list], ['foo', 'meta'], + "still has the right methods"); + +done_testing; diff --git a/t/roles/role.t b/t/roles/role.t new file mode 100644 index 0000000..083e5ac --- /dev/null +++ b/t/roles/role.t @@ -0,0 +1,154 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +NOTE: + +Should we be testing here that the has & override +are injecting their methods correctly? In other +words, should 'has_method' return true for them? + +=cut + +{ + package FooRole; + use Moose::Role; + + our $VERSION = '0.01'; + + has 'bar' => (is => 'rw', isa => 'Foo'); + has 'baz' => (is => 'ro'); + + sub foo { 'FooRole::foo' } + sub boo { 'FooRole::boo' } + + before 'boo' => sub { "FooRole::boo:before" }; + + after 'boo' => sub { "FooRole::boo:after1" }; + after 'boo' => sub { "FooRole::boo:after2" }; + + around 'boo' => sub { "FooRole::boo:around" }; + + override 'bling' => sub { "FooRole::bling:override" }; + override 'fling' => sub { "FooRole::fling:override" }; + + ::isnt( ::exception { extends() }, undef, '... extends() is not supported' ); + ::isnt( ::exception { augment() }, undef, '... augment() is not supported' ); + ::isnt( ::exception { inner() }, undef, '... inner() is not supported' ); + + no Moose::Role; +} + +my $foo_role = FooRole->meta; +isa_ok($foo_role, 'Moose::Meta::Role'); +isa_ok($foo_role, 'Class::MOP::Module'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); + +isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); + +ok($foo_role->has_method('boo'), '... FooRole has the boo method'); +is($foo_role->get_method('boo')->body, \&FooRole::boo, '... FooRole got the boo method'); + +isa_ok($foo_role->get_method('boo'), 'Moose::Meta::Role::Method'); + +is_deeply( + [ sort $foo_role->get_method_list() ], + [ 'boo', 'foo', 'meta' ], + '... got the right method list'); + +ok(FooRole->can('foo'), "locally defined methods are still there"); +ok(!FooRole->can('has'), "sugar was unimported"); + +# attributes ... + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +my $bar_attr = $foo_role->get_attribute('bar'); +is($bar_attr->{is}, 'rw', + 'bar attribute is rw'); +is($bar_attr->{isa}, 'Foo', + 'bar attribute isa Foo'); +is(ref($bar_attr->{definition_context}), 'HASH', + 'bar\'s definition context is a hash'); +is($bar_attr->{definition_context}->{package}, 'FooRole', + 'bar was defined in FooRole'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +my $baz_attr = $foo_role->get_attribute('baz'); +is($baz_attr->{is}, 'ro', + 'baz attribute is ro'); +is(ref($baz_attr->{definition_context}), 'HASH', + 'bar\'s definition context is a hash'); +is($baz_attr->{definition_context}->{package}, 'FooRole', + 'baz was defined in FooRole'); + +# method modifiers + +ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); +is(($foo_role->get_before_method_modifiers('boo'))[0]->(), + "FooRole::boo:before", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); + +ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier'); +is(($foo_role->get_after_method_modifiers('boo'))[0]->(), + "FooRole::boo:after1", + '... got the right method back'); +is(($foo_role->get_after_method_modifiers('boo'))[1]->(), + "FooRole::boo:after2", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('after') ], + [ 'boo' ], + '... got the right list of after method modifiers'); + +ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier'); +is(($foo_role->get_around_method_modifiers('boo'))[0]->(), + "FooRole::boo:around", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('around') ], + [ 'boo' ], + '... got the right list of around method modifiers'); + +## overrides + +ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier'); +is($foo_role->get_override_method_modifier('bling')->(), + "FooRole::bling:override", + '... got the right method back'); + +ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier'); +is($foo_role->get_override_method_modifier('fling')->(), + "FooRole::fling:override", + '... got the right method back'); + +is_deeply( + [ sort $foo_role->get_method_modifier_list('override') ], + [ 'bling', 'fling' ], + '... got the right list of override method modifiers'); + +done_testing; diff --git a/t/roles/role_attr_application.t b/t/roles/role_attr_application.t new file mode 100644 index 0000000..05720e9 --- /dev/null +++ b/t/roles/role_attr_application.t @@ -0,0 +1,291 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use Moose::Util qw( does_role ); + +{ + package Foo::Meta::Attribute; + use Moose::Role; +} + +{ + package Foo::Meta::Attribute2; + use Moose::Role; +} + +{ + package Foo::Role; + use Moose::Role; + + has foo => (is => 'ro'); +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Foo::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Foo::Meta::Attribute2'] }, + ); + with 'Foo::Role'; + + has bar => (is => 'ro'); +} + +ok(Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the role metarole defined in the class applied"); + +{ + package Bar::Meta::Attribute; + use Moose::Role; +} + +{ + package Bar::Meta::Attribute2; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Bar::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Bar::Meta::Attribute2'] }, + ); + + has foo => (is => 'ro'); +} + +{ + package Bar; + use Moose; + with 'Bar::Role'; + + has bar => (is => 'ro'); +} + +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'), "attrs defined in the class don't get the class metarole from the role applied"); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); + +{ + package Baz::Meta::Attribute; + use Moose::Role; +} + +{ + package Baz::Meta::Attribute2; + use Moose::Role; +} + +{ + package Baz::Role; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, + ); + + has foo => (is => 'ro'); +} + +{ + package Baz; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, + ); + with 'Baz::Role'; + + has bar => (is => 'ro'); +} + +ok(Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); +ok(!Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); +ok(!Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); + +{ + package Accessor::Modifying::Role; + use Moose::Role; + + around _process_options => sub { + my $orig = shift; + my $self = shift; + my ($name, $params) = @_; + $self->$orig(@_); + $params->{reader} .= '_foo'; + }; +} + +{ + package Plain::Role; + use Moose::Role; + + has foo => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + package Class::With::Trait; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['Accessor::Modifying::Role'], + }, + ); + with 'Plain::Role'; + + has bar => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + can_ok('Class::With::Trait', 'foo'); + can_ok('Class::With::Trait', 'bar_foo'); +} + +{ + package Role::With::Trait; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Accessor::Modifying::Role'], + }, + ); + with 'Plain::Role'; + + has foo => ( + is => 'ro', + isa => 'Str', + ); + + sub foo_test { + my $self = shift; + return $self->can('foo_foo'); + } +} + +{ + package Class::With::Role::With::Trait; + use Moose; + with 'Role::With::Trait'; + + has bar => ( + is => 'ro', + isa => 'Str', + ); + + sub bar_test { + my $self = shift; + return $self->can('bar'); + } +} + +{ + can_ok('Class::With::Role::With::Trait', 'foo_foo'); + can_ok('Class::With::Role::With::Trait', 'bar'); +} + +{ + package Quux::Meta::Role::Attribute; + use Moose::Role; +} + +{ + package Quux::Role1; + use Moose::Role; + + has foo => (traits => ['Quux::Meta::Role::Attribute'], is => 'ro'); + has baz => (is => 'ro'); +} + +{ + package Quux::Role2; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Quux::Meta::Role::Attribute'] + }, + ); + + has bar => (is => 'ro'); +} + +{ + package Quux; + use Moose; + with 'Quux::Role1', 'Quux::Role2'; +} + +{ + my $foo = Quux->meta->get_attribute('foo'); + does_ok($foo, 'Quux::Meta::Role::Attribute', + "individual attribute trait applied correctly"); + + my $baz = Quux->meta->get_attribute('baz'); + ok(! does_role($baz, 'Quux::Meta::Role::Attribute'), + "applied_attribute traits do not end up applying to attributes from other roles during composition"); + + my $bar = Quux->meta->get_attribute('bar'); + does_ok($bar, 'Quux::Meta::Role::Attribute', + "attribute metarole applied correctly"); +} + +{ + package HasMeta; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Quux::Meta::Role::Attribute'] + }, + ); + + has foo => (is => 'ro'); +} + +{ + package NoMeta; + use Moose::Role; + + with 'HasMeta'; + + has bar => (is => 'ro'); +} + +{ + package ConsumesBoth; + use Moose; + with 'HasMeta', 'NoMeta'; +} + +{ + my $foo = ConsumesBoth->meta->get_attribute('foo'); + does_ok($foo, 'Quux::Meta::Role::Attribute', + 'applied_attribute traits are preserved when one role consumes another'); + + my $bar = ConsumesBoth->meta->get_attribute('bar'); + ok(! does_role($bar, 'Quux::Meta::Role::Attribute'), + "applied_attribute traits do not spill over from consumed role"); +} + + + +done_testing; diff --git a/t/roles/role_attribute_conflict.t b/t/roles/role_attribute_conflict.t new file mode 100644 index 0000000..d4ad4c5 --- /dev/null +++ b/t/roles/role_attribute_conflict.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package My::Role1; + use Moose::Role; + + has foo => ( + is => 'ro', + ); + +} + +{ + package My::Role2; + use Moose::Role; + + has foo => ( + is => 'ro', + ); + + ::like( ::exception { with 'My::Role1' }, qr/attribute conflict.+My::Role2.+foo/, 'attribute conflict when composing one role into another' ); +} + +done_testing; diff --git a/t/roles/role_attrs.t b/t/roles/role_attrs.t new file mode 100644 index 0000000..6c1ea8b --- /dev/null +++ b/t/roles/role_attrs.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Role; +use Moose::Util; + +my $role1 = Moose::Meta::Role->initialize('Foo'); +$role1->add_attribute( foo => ( is => 'ro' ) ); + +ok( $role1->has_attribute('foo'), 'Foo role has a foo attribute' ); + +my $foo_attr = $role1->get_attribute('foo'); +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is Foo role' +); + +isa_ok( + $foo_attr->attribute_for_class('Moose::Meta::Attribute'), + 'Moose::Meta::Attribute', + 'attribute returned by ->attribute_for_class' +); + +my $role2 = Moose::Meta::Role->initialize('Bar'); +$role1->apply($role2); + +ok( $role2->has_attribute('foo'), 'Bar role has a foo attribute' ); + +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is still Foo role' +); + +isa_ok( + $foo_attr->attribute_for_class('Moose::Meta::Attribute'), + 'Moose::Meta::Attribute', + 'attribute returned by ->attribute_for_class' +); + +my $role3 = Moose::Meta::Role->initialize('Baz'); +my $combined = Moose::Meta::Role->combine( [ $role1->name ], [ $role3->name ] ); + +ok( $combined->has_attribute('foo'), 'combined role has a foo attribute' ); + +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is still Foo role' +); + +done_testing; diff --git a/t/roles/role_compose_requires.t b/t/roles/role_compose_requires.t new file mode 100644 index 0000000..06337ff --- /dev/null +++ b/t/roles/role_compose_requires.t @@ -0,0 +1,132 @@ +use strict; +use warnings; + +# See https://rt.cpan.org/Ticket/Display.html?id=46347 + +use Test::More; +use Test::Fatal; + +{ + package My::Role1; + use Moose::Role; + requires 'test_output'; +} + +{ + package My::Role2; + use Moose::Role; + has test_output => ( is => 'rw' ); + with 'My::Role1'; +} + +{ + package My::Role3; + use Moose::Role; + sub test_output { } + with 'My::Role1'; +} + +{ + package My::Role4; + use Moose::Role; + has test_output => ( is => 'rw' ); +} + +{ + package My::Role5; + use Moose::Role; + sub test_output { } +} + +{ + package My::Base1; + use Moose; + has test_output => ( is => 'rw' ); +} + +{ + package My::Base2; + use Moose; + sub test_output { } +} + +# Roles providing attributes/methods should satisfy requires() of other +# roles they consume. +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test1; use Moose; with 'My::Role2'; }, undef, 'role2(provides attribute) consumes role1' ); +} + +is( exception { package My::Test2; use Moose; with 'My::Role3'; }, undef, 'role3(provides method) consumes role1' ); + +# As I understand the design, Roles composed in the same with() statement +# should NOT demonstrate ordering dependency. Alter these tests if that +# assumption is false. -Vince Veselosky +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test3; use Moose; with 'My::Role4', 'My::Role1'; }, undef, 'class consumes role4(provides attribute), role1' ); +} + +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test4; use Moose; with 'My::Role1', 'My::Role4'; }, undef, 'class consumes role1, role4(provides attribute)' ); +} + +is( exception { package My::Test5; use Moose; with 'My::Role5', 'My::Role1'; }, undef, 'class consumes role5(provides method), role1' ); + +is( exception { package My::Test6; use Moose; with 'My::Role1', 'My::Role5'; }, undef, 'class consumes role1, role5(provides method)' ); + +# Inherited methods/attributes should satisfy requires(), as long as +# extends() comes first in code order. +is( exception { + package My::Test7; + use Moose; + extends 'My::Base1'; + with 'My::Role1'; +}, undef, 'class extends base1(provides attribute), consumes role1' ); + +is( exception { + package My::Test8; + use Moose; + extends 'My::Base2'; + with 'My::Role1'; +}, undef, 'class extends base2(provides method), consumes role1' ); + +# Attributes/methods implemented in class should satisfy requires() +is( exception { + + package My::Test9; + use Moose; + has 'test_output', is => 'rw'; + with 'My::Role1'; +}, undef, 'class provides attribute, consumes role1' ); + +is( exception { + + package My::Test10; + use Moose; + sub test_output { } + with 'My::Role1'; +}, undef, 'class provides method, consumes role1' ); + +# Roles composed in separate with() statements SHOULD demonstrate ordering +# dependency. See comment with tests 3-6 above. +is( exception { + package My::Test11; + use Moose; + with 'My::Role4'; + with 'My::Role1'; +}, undef, 'class consumes role4(provides attribute); consumes role1' ); + +isnt( exception { package My::Test12; use Moose; with 'My::Role1'; with 'My::Role4'; }, undef, 'class consumes role1; consumes role4(provides attribute)' ); + +is( exception { + package My::Test13; + use Moose; + with 'My::Role5'; + with 'My::Role1'; +}, undef, 'class consumes role5(provides method); consumes role1' ); + +isnt( exception { package My::Test14; use Moose; with 'My::Role1'; with 'My::Role5'; }, undef, 'class consumes role1; consumes role5(provides method)' ); + +done_testing; diff --git a/t/roles/role_composite.t b/t/roles/role_composite.t new file mode 100644 index 0000000..f3c52aa --- /dev/null +++ b/t/roles/role_composite.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + package Role::Bar; + use Moose::Role; + + package Role::Baz; + use Moose::Role; + + package Role::Gorch; + use Moose::Role; +} + +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::Baz->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar|Role::Baz', '... got the composite role name'); + + is_deeply($c->get_roles, [ + Role::Foo->meta, + Role::Bar->meta, + Role::Baz->meta, + ], '... got the right roles'); + + ok($c->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + ); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this composed okay' ); + + ok(!$c->is_anon, '... composite is not anonymous'); + + ##... now nest 'em + { + my $c2 = Moose::Meta::Role::Composite->new( + roles => [ + $c, + Role::Gorch->meta, + ] + ); + isa_ok($c2, 'Moose::Meta::Role::Composite'); + + is($c2->name, 'Role::Foo|Role::Bar|Role::Baz|Role::Gorch', '... got the composite role name'); + + is_deeply($c2->get_roles, [ + $c, + Role::Gorch->meta, + ], '... got the right roles'); + + ok($c2->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + Role::Gorch + ); + + ok(!$c2->is_anon, '... composite is not anonymous'); + } +} + +done_testing; diff --git a/t/roles/role_composite_exclusion.t b/t/roles/role_composite_exclusion.t new file mode 100644 index 0000000..ed44308 --- /dev/null +++ b/t/roles/role_composite_exclusion.t @@ -0,0 +1,107 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + package Role::Bar; + use Moose::Role; + + package Role::ExcludesFoo; + use Moose::Role; + excludes 'Role::Foo'; + + package Role::DoesExcludesFoo; + use Moose::Role; + with 'Role::ExcludesFoo'; + + package Role::DoesFoo; + use Moose::Role; + with 'Role::Foo'; +} + +ok(Role::ExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); +ok(Role::DoesExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); + +# test simple exclusion +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ExcludesFoo->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test no conflicts +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives as expected' ); +} + +# test no conflicts w/exclusion +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Bar->meta, + Role::ExcludesFoo->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives as expected' ); + + is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles'); +} + + +# test conflict with an "inherited" exclusion +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::DoesExcludesFoo->meta, + ] + ) + ); + +}, undef, '... this fails as expected' ); + +# test conflict with an "inherited" exclusion of an "inherited" role +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::DoesFoo->meta, + Role::DoesExcludesFoo->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +done_testing; diff --git a/t/roles/role_composition_attributes.t b/t/roles/role_composition_attributes.t new file mode 100644 index 0000000..f11a0c5 --- /dev/null +++ b/t/roles/role_composition_attributes.t @@ -0,0 +1,93 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + has 'foo' => (is => 'rw'); + + package Role::Bar; + use Moose::Role; + has 'bar' => (is => 'rw'); + + package Role::FooConflict; + use Moose::Role; + has 'foo' => (is => 'rw'); + + package Role::BarConflict; + use Moose::Role; + has 'bar' => (is => 'rw'); + + package Role::AnotherFooConflict; + use Moose::Role; + with 'Role::FooConflict'; +} + +# test simple attributes +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_attribute_list ], + [ 'bar', 'foo' ], + '... got the right list of attributes' + ); +} + +# test simple conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test complex conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + Role::BarConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test simple conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::AnotherFooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +done_testing; diff --git a/t/roles/role_composition_conflict_detection.t b/t/roles/role_composition_conflict_detection.t new file mode 100644 index 0000000..d2b693a --- /dev/null +++ b/t/roles/role_composition_conflict_detection.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Util qw( find_meta ); + +{ + package RoleA; + use Moose::Role; + + sub foo { 42 } +} + +{ + package RoleB; + use Moose::Role; + + with 'RoleA'; +} + +{ + package RoleC; + use Moose::Role; + + sub foo { 84 } +} + +{ + my $composite + = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } + qw( RoleA RoleB RoleC ) ); + ok( $composite->requires_method('foo'), 'Composite of [ABC] requires a foo method' ); + ok( ! $composite->has_method('foo'), 'Composite of [ABC] does not also have a foo method' ); +} + +{ + my $composite + = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } + qw( RoleA RoleC RoleB ) ); + ok( $composite->requires_method('foo'), 'Composite of [ACB] requires a foo method' ); + ok( ! $composite->has_method('foo'), 'Composite of [ACB] does not also have a foo method' ); +} + +done_testing; diff --git a/t/roles/role_composition_errors.t b/t/roles/role_composition_errors.t new file mode 100644 index 0000000..8fe9178 --- /dev/null +++ b/t/roles/role_composition_errors.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Foo::Role; + use Moose::Role; + + requires 'foo'; +} + +is_deeply( + [ sort Foo::Role->meta->get_required_method_list ], + ['foo'], + '... the Foo::Role has a required method (foo)' +); + +# classes which does not implement required method +{ + + package Foo::Class; + use Moose; + + ::isnt( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Foo::Class' ); +} + +# class which does implement required method +{ + + package Bar::Class; + use Moose; + + ::isnt( ::exception { with('Foo::Class') }, undef, '... cannot consume a class, it must be a role' ); + ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Class' ); + + sub foo {'Bar::Class::foo'} +} + +# role which does implement required method +{ + + package Bar::Role; + use Moose::Role; + + ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Role' ); + + sub foo {'Bar::Role::foo'} +} + +is_deeply( + [ sort Bar::Role->meta->get_required_method_list ], + [], + '... the Bar::Role has not inherited the required method from Foo::Role' +); + +# role which does not implement required method +{ + + package Baz::Role; + use Moose::Role; + + ::is( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Baz::Role' ); +} + +is_deeply( + [ sort Baz::Role->meta->get_required_method_list ], + ['foo'], + '... the Baz::Role has inherited the required method from Foo::Role' +); + +# classes which does not implement required method +{ + + package Baz::Class; + use Moose; + + ::isnt( ::exception { with('Baz::Role') }, undef, '... no foo method implemented by Baz::Class2' ); +} + +# class which does implement required method +{ + + package Baz::Class2; + use Moose; + + ::is( ::exception { with('Baz::Role') }, undef, '... has a foo method implemented by Baz::Class2' ); + + sub foo {'Baz::Class2::foo'} +} + + +{ + package Quux::Role; + use Moose::Role; + + requires qw( meth1 meth2 meth3 meth4 ); +} + +# RT #41119 +{ + + package Quux::Class; + use Moose; + + ::like( ::exception { with('Quux::Role') }, qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); +} + +{ + package Quux::Class2; + use Moose; + + sub meth1 { } + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); +} + +{ + package Quux::Class3; + use Moose; + + has 'meth1' => ( is => 'ro' ); + has 'meth2' => ( is => 'ro' ); + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/, 'exception mentions all the missing methods at once, but not the accessors' ); +} + +{ + package Quux::Class4; + use Moose; + + sub meth1 { } + has 'meth2' => ( is => 'ro' ); + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/, 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists' ); +} + +done_testing; diff --git a/t/roles/role_composition_method_mods.t b/t/roles/role_composition_method_mods.t new file mode 100644 index 0000000..8f9e4fc --- /dev/null +++ b/t/roles/role_composition_method_mods.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + before foo => sub { 'Role::Foo::foo' }; + around foo => sub { 'Role::Foo::foo' }; + after foo => sub { 'Role::Foo::foo' }; + around baz => sub { [ 'Role::Foo', @{shift->(@_)} ] }; + + package Role::Bar; + use Moose::Role; + + before bar => sub { 'Role::Bar::bar' }; + around bar => sub { 'Role::Bar::bar' }; + after bar => sub { 'Role::Bar::bar' }; + + package Role::Baz; + use Moose::Role; + + with 'Role::Foo'; + around baz => sub { [ 'Role::Baz', @{shift->(@_)} ] }; + +} + +{ + package Class::FooBar; + use Moose; + + with 'Role::Baz'; + sub foo { 'placeholder' } + sub baz { ['Class::FooBar'] } +} + +#test modifier call order +{ + is_deeply( + Class::FooBar->baz, + ['Role::Baz','Role::Foo','Class::FooBar'] + ); +} + +# test simple overrides +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_modifier_list('before') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_method_modifier_list('after') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_method_modifier_list('around') ], + [ 'bar', 'baz', 'foo' ], + '... got the right list of methods' + ); +} + +done_testing; diff --git a/t/roles/role_composition_methods.t b/t/roles/role_composition_methods.t new file mode 100644 index 0000000..62d70c8 --- /dev/null +++ b/t/roles/role_composition_methods.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + sub foo { 'Role::Foo::foo' } + + package Role::Bar; + use Moose::Role; + + sub bar { 'Role::Bar::bar' } + + package Role::FooConflict; + use Moose::Role; + + sub foo { 'Role::FooConflict::foo' } + + package Role::BarConflict; + use Moose::Role; + + sub bar { 'Role::BarConflict::bar' } + + package Role::AnotherFooConflict; + use Moose::Role; + with 'Role::FooConflict'; + + sub baz { 'Role::AnotherFooConflict::baz' } +} + +# test simple attributes +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); +} + +# test simple conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'foo' ], + '... got the right list of required methods' + ); +} + +# test complex conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + Role::BarConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar', 'foo' ], + '... got the right list of required methods' + ); +} + +# test simple conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::AnotherFooConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [ 'baz' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'foo' ], + '... got the right list of required methods' + ); +} + +done_testing; diff --git a/t/roles/role_composition_override.t b/t/roles/role_composition_override.t new file mode 100644 index 0000000..dcabe76 --- /dev/null +++ b/t/roles/role_composition_override.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + override foo => sub { 'Role::Foo::foo' }; + + package Role::Bar; + use Moose::Role; + + override bar => sub { 'Role::Bar::bar' }; + + package Role::FooConflict; + use Moose::Role; + + override foo => sub { 'Role::FooConflict::foo' }; + + package Role::FooMethodConflict; + use Moose::Role; + + sub foo { 'Role::FooConflict::foo' } + + package Role::BarMethodConflict; + use Moose::Role; + + sub bar { 'Role::BarConflict::bar' } +} + +# test simple overrides +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives ok' ); + + is_deeply( + [ sort $c->get_method_modifier_list('override') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); +} + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooMethodConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooMethodConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +{ + { + package Foo; + use Moose::Role; + + override test => sub { print "override test in Foo" }; + } + + my $exception = exception { + { + package Bar; + use Moose::Role; + + override test => sub { print "override test in Bar" }; + with 'Foo'; + } + }; + + like( + $exception, + qr/\QRole 'Foo' has encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "Foo & Bar, both roles are overriding test method"); +} + +{ + { + package Role::A; + use Moose::Role; + + override a_method => sub { "a method in A" }; + } + + { + package Role::B; + use Moose::Role; + with 'Role::A'; + } + + { + package Role::C; + use Moose::Role; + with 'Role::A' + } + + my $exception = exception { + { + package Role::D; + use Moose::Role; + with 'Role::B'; + with 'Role::C'; + } + }; + + is( $exception, undef, "this works fine"); +} + +done_testing; diff --git a/t/roles/role_composition_req_methods.t b/t/roles/role_composition_req_methods.t new file mode 100644 index 0000000..7209aa9 --- /dev/null +++ b/t/roles/role_composition_req_methods.t @@ -0,0 +1,123 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + requires 'foo'; + + package Role::Bar; + use Moose::Role; + requires 'bar'; + + package Role::ProvidesFoo; + use Moose::Role; + sub foo { 'Role::ProvidesFoo::foo' } + + package Role::ProvidesBar; + use Moose::Role; + sub bar { 'Role::ProvidesBar::bar' } +} + +# test simple requirement +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar', 'foo' ], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar' ], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + Role::ProvidesBar->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ ], + '... got the right list of required methods' + ); +} + +done_testing; diff --git a/t/roles/role_conflict_detection.t b/t/roles/role_conflict_detection.t new file mode 100644 index 0000000..0f80f55 --- /dev/null +++ b/t/roles/role_conflict_detection.t @@ -0,0 +1,595 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +Mutually recursive roles. + +=cut + +{ + package Role::Foo; + use Moose::Role; + + requires 'foo'; + + sub bar { 'Role::Foo::bar' } + + package Role::Bar; + use Moose::Role; + + requires 'bar'; + + sub foo { 'Role::Bar::foo' } +} + +{ + package My::Test1; + use Moose; + + ::is( ::exception { + with 'Role::Foo', 'Role::Bar'; + }, undef, '... our mutually recursive roles combine okay' ); + + package My::Test2; + use Moose; + + ::is( ::exception { + with 'Role::Bar', 'Role::Foo'; + }, undef, '... our mutually recursive roles combine okay (no matter what order)' ); +} + +my $test1 = My::Test1->new; +isa_ok($test1, 'My::Test1'); + +ok($test1->does('Role::Foo'), '... $test1 does Role::Foo'); +ok($test1->does('Role::Bar'), '... $test1 does Role::Bar'); + +can_ok($test1, 'foo'); +can_ok($test1, 'bar'); + +is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked'); +is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked'); + +my $test2 = My::Test2->new; +isa_ok($test2, 'My::Test2'); + +ok($test2->does('Role::Foo'), '... $test2 does Role::Foo'); +ok($test2->does('Role::Bar'), '... $test2 does Role::Bar'); + +can_ok($test2, 'foo'); +can_ok($test2, 'bar'); + +is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked'); +is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked'); + +# check some meta-stuff + +ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method'); +ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method'); + +ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method'); +ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method'); + +=pod + +Role method conflicts + +=cut + +{ + package Role::Bling; + use Moose::Role; + + sub bling { 'Role::Bling::bling' } + + package Role::Bling::Bling; + use Moose::Role; + + sub bling { 'Role::Bling::Bling::bling' } +} + +{ + package My::Test3; + use Moose; + + ::like( ::exception { + with 'Role::Bling', 'Role::Bling::Bling'; + }, qr/Due to a method name conflict in roles 'Role::Bling' and 'Role::Bling::Bling', the method 'bling' must be implemented or excluded by 'My::Test3'/, '... role methods conflict and method was required' ); + + package My::Test4; + use Moose; + + ::is( ::exception { + with 'Role::Bling'; + with 'Role::Bling::Bling'; + }, undef, '... role methods didnt conflict when manually combined' ); + + package My::Test5; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling'; + with 'Role::Bling'; + }, undef, '... role methods didnt conflict when manually combined (in opposite order)' ); + + package My::Test6; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', 'Role::Bling'; + }, undef, '... role methods didnt conflict when manually resolved' ); + + sub bling { 'My::Test6::bling' } + + package My::Test7; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', { -excludes => ['bling'] }, 'Role::Bling'; + }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded' ); + + package My::Test8; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', { -excludes => ['bling'], -alias => { bling => 'bling_bling' } }, 'Role::Bling'; + }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded and aliased' ); +} + +ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict'); +ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test7->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test8->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test8->meta->has_method('bling_bling'), '... we did get the aliased method too'); + +ok(!My::Test3->does('Role::Bling'), '... our class does() the correct roles'); +ok(!My::Test3->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test4->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test4->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test5->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test5->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test6->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test6->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test7->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test7->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Bling::Bling'), '... our class does() the correct roles'); + +is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added'); +is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added'); +is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method'); +is(My::Test7->bling, 'Role::Bling::bling', '... and we got the non-excluded method'); +is(My::Test8->bling, 'Role::Bling::bling', '... and we got the non-excluded/aliased method'); +is(My::Test8->bling_bling, 'Role::Bling::Bling::bling', '... and the aliased method comes from the correct role'); + +# check how this affects role compostion + +{ + package Role::Bling::Bling::Bling; + use Moose::Role; + + with 'Role::Bling::Bling'; + + sub bling { 'Role::Bling::Bling::Bling::bling' } +} + +ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling'); +ok(Role::Bling::Bling->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role'); +ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... dont have the bling method in Role::Bling::Bling::Bling'); +is(Role::Bling::Bling::Bling->meta->get_method('bling')->(), + 'Role::Bling::Bling::Bling::bling', + '... still got the bling method in Role::Bling::Bling::Bling'); + + +=pod + +Role attribute conflicts + +=cut + +{ + package Role::Boo; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost'); + + package Role::Boo::Hoo; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost'); +} + +{ + package My::Test7; + use Moose; + + ::like( ::exception { + with 'Role::Boo', 'Role::Boo::Hoo'; + }, qr/We have encountered an attribute conflict.+ghost/ ); + + package My::Test8; + use Moose; + + ::is( ::exception { + with 'Role::Boo'; + with 'Role::Boo::Hoo'; + }, undef, '... role attrs didnt conflict when manually combined' ); + + package My::Test9; + use Moose; + + ::is( ::exception { + with 'Role::Boo::Hoo'; + with 'Role::Boo'; + }, undef, '... role attrs didnt conflict when manually combined' ); + + package My::Test10; + use Moose; + + has 'ghost' => (is => 'ro', default => 'My::Test10::ghost'); + + ::like( ::exception { + with 'Role::Boo', 'Role::Boo::Hoo'; + }, qr/We have encountered an attribute conflict/, '... role attrs conflict and cannot be manually disambiguted' ); + +} + +ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict'); +ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); +ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); +ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)'); + +ok(!My::Test7->does('Role::Boo'), '... our class does() the correct roles'); +ok(!My::Test7->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Boo'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(My::Test9->does('Role::Boo'), '... our class does() the correct roles'); +ok(My::Test9->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(!My::Test10->does('Role::Boo'), '... our class does() the correct roles'); +ok(!My::Test10->does('Role::Boo::Hoo'), '... our class does() the correct roles'); + +can_ok('My::Test8', 'ghost'); +can_ok('My::Test9', 'ghost'); +can_ok('My::Test10', 'ghost'); + +is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value'); +is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value'); +is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value'); + +=pod + +Role override method conflicts + +=cut + +{ + package Role::Plot; + use Moose::Role; + + override 'twist' => sub { + super() . ' -> Role::Plot::twist'; + }; + + package Role::Truth; + use Moose::Role; + + override 'twist' => sub { + super() . ' -> Role::Truth::twist'; + }; +} + +{ + package My::Test::Base; + use Moose; + + sub twist { 'My::Test::Base::twist' } + + package My::Test11; + use Moose; + + extends 'My::Test::Base'; + + ::is( ::exception { + with 'Role::Truth'; + }, undef, '... composed the role with override okay' ); + + package My::Test12; + use Moose; + + extends 'My::Test::Base'; + + ::is( ::exception { + with 'Role::Plot'; + }, undef, '... composed the role with override okay' ); + + package My::Test13; + use Moose; + + ::isnt( ::exception { + with 'Role::Plot'; + }, undef, '... cannot compose it because we have no superclass' ); + + package My::Test14; + use Moose; + + extends 'My::Test::Base'; + + ::like( ::exception { + with 'Role::Plot', 'Role::Truth'; + }, qr/Two \'override\' methods of the same name encountered/, '... cannot compose it because we have no superclass' ); +} + +ok(My::Test11->meta->has_method('twist'), '... the twist method has been added'); +ok(My::Test12->meta->has_method('twist'), '... the twist method has been added'); +ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added'); +ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added'); + +ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles'); +ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles'); +ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles'); +ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles'); +ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles'); +ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles'); +ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles'); + +is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return'); +is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return'); +ok(!My::Test13->can('twist'), '... no twist method here at all'); +is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)'); + +{ + package Role::Reality; + use Moose::Role; + + ::like( ::exception { + with 'Role::Plot'; + }, qr/A local method of the same name as been found/, '... could not compose roles here, it dies' ); + + sub twist { + 'Role::Reality::twist'; + } +} + +ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added'); +#ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles'); +is(Role::Reality->meta->get_method('twist')->(), + 'Role::Reality::twist', + '... the twist method returns the right value'); + +# Ovid's test case from rt.cpan.org #44 +{ + package Role1; + use Moose::Role; + + sub foo {} +} +{ + package Role2; + use Moose::Role; + + sub foo {} +} +{ + package Conflicts; + use Moose; + + ::like( ::exception { + with qw(Role1 Role2); + }, qr/Due to a method name conflict in roles 'Role1' and 'Role2', the method 'foo' must be implemented or excluded by 'Conflicts'/ ); +} + +=pod + +Role conflicts between attributes and methods + +[15:23] <kolibrie> when class defines method and role defines method, class wins +[15:24] <kolibrie> when class 'has' method and role defines method, class wins +[15:24] <kolibrie> when class defines method and role 'has' method, role wins +[15:24] <kolibrie> when class 'has' method and role 'has' method, role wins +[15:24] <kolibrie> which means when class 'has' method and two roles 'has' method, no tiebreak is detected +[15:24] <perigrin> this is with role and has declaration in the exact same order in every case? +[15:25] <kolibrie> yes +[15:25] <perigrin> interesting +[15:25] <kolibrie> that's what I thought +[15:26] <kolibrie> does that sound like something I should write a test for? +[15:27] <perigrin> stevan, ping? +[15:27] <perigrin> I'm not sure what the right answer for composition is. +[15:27] <perigrin> who should win +[15:27] <perigrin> if I were to guess I'd say the class should always win. +[15:27] <kolibrie> that would be my guess, but I thought I would ask to make sure +[15:29] <stevan> kolibrie: please write a test +[15:29] <stevan> I am not exactly sure who should win either,.. but I suspect it is not working correctly right now +[15:29] <stevan> I know exactly why it is doing what it is doing though + +Now I have to decide actually what happens, and how to fix it. +- SL + +{ + package Role::Method; + use Moose::Role; + + sub ghost { 'Role::Method::ghost' } + + package Role::Method2; + use Moose::Role; + + sub ghost { 'Role::Method2::ghost' } + + package Role::Attribute; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Attribute::ghost'); + + package Role::Attribute2; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Attribute2::ghost'); +} + +{ + package My::Test15; + use Moose; + + ::lives_ok { + with 'Role::Method'; + } '... composed the method role into the method class'; + + sub ghost { 'My::Test15::ghost' } + + package My::Test16; + use Moose; + + ::lives_ok { + with 'Role::Method'; + } '... composed the method role into the attribute class'; + + has 'ghost' => (is => 'ro', default => 'My::Test16::ghost'); + + package My::Test17; + use Moose; + + ::lives_ok { + with 'Role::Attribute'; + } '... composed the attribute role into the method class'; + + sub ghost { 'My::Test17::ghost' } + + package My::Test18; + use Moose; + + ::lives_ok { + with 'Role::Attribute'; + } '... composed the attribute role into the attribute class'; + + has 'ghost' => (is => 'ro', default => 'My::Test18::ghost'); + + package My::Test19; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Method2'; + } '... composed method roles into class with method tiebreaker'; + + sub ghost { 'My::Test19::ghost' } + + package My::Test20; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Method2'; + } '... composed method roles into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test20::ghost'); + + package My::Test21; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Attribute2'; + } '... composed attribute roles into class with method tiebreaker'; + + sub ghost { 'My::Test21::ghost' } + + package My::Test22; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Attribute2'; + } '... composed attribute roles into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test22::ghost'); + + package My::Test23; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Attribute'; + } '... composed method and attribute role into class with method tiebreaker'; + + sub ghost { 'My::Test23::ghost' } + + package My::Test24; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Attribute'; + } '... composed method and attribute role into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test24::ghost'); + + package My::Test25; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Method'; + } '... composed attribute and method role into class with method tiebreaker'; + + sub ghost { 'My::Test25::ghost' } + + package My::Test26; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Method'; + } '... composed attribute and method role into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test26::ghost'); +} + +my $test15 = My::Test15->new; +isa_ok($test15, 'My::Test15'); +is($test15->ghost, 'My::Test15::ghost', '... we access the method from the class and ignore the role method'); + +my $test16 = My::Test16->new; +isa_ok($test16, 'My::Test16'); +is($test16->ghost, 'My::Test16::ghost', '... we access the attribute from the class and ignore the role method'); + +my $test17 = My::Test17->new; +isa_ok($test17, 'My::Test17'); +is($test17->ghost, 'My::Test17::ghost', '... we access the method from the class and ignore the role attribute'); + +my $test18 = My::Test18->new; +isa_ok($test18, 'My::Test18'); +is($test18->ghost, 'My::Test18::ghost', '... we access the attribute from the class and ignore the role attribute'); + +my $test19 = My::Test19->new; +isa_ok($test19, 'My::Test19'); +is($test19->ghost, 'My::Test19::ghost', '... we access the method from the class and ignore the role methods'); + +my $test20 = My::Test20->new; +isa_ok($test20, 'My::Test20'); +is($test20->ghost, 'My::Test20::ghost', '... we access the attribute from the class and ignore the role methods'); + +my $test21 = My::Test21->new; +isa_ok($test21, 'My::Test21'); +is($test21->ghost, 'My::Test21::ghost', '... we access the method from the class and ignore the role attributes'); + +my $test22 = My::Test22->new; +isa_ok($test22, 'My::Test22'); +is($test22->ghost, 'My::Test22::ghost', '... we access the attribute from the class and ignore the role attributes'); + +my $test23 = My::Test23->new; +isa_ok($test23, 'My::Test23'); +is($test23->ghost, 'My::Test23::ghost', '... we access the method from the class and ignore the role method and attribute'); + +my $test24 = My::Test24->new; +isa_ok($test24, 'My::Test24'); +is($test24->ghost, 'My::Test24::ghost', '... we access the attribute from the class and ignore the role method and attribute'); + +my $test25 = My::Test25->new; +isa_ok($test25, 'My::Test25'); +is($test25->ghost, 'My::Test25::ghost', '... we access the method from the class and ignore the role attribute and method'); + +my $test26 = My::Test26->new; +isa_ok($test26, 'My::Test26'); +is($test26->ghost, 'My::Test26::ghost', '... we access the attribute from the class and ignore the role attribute and method'); + +=cut + +done_testing; diff --git a/t/roles/role_conflict_edge_cases.t b/t/roles/role_conflict_edge_cases.t new file mode 100644 index 0000000..5fb87e0 --- /dev/null +++ b/t/roles/role_conflict_edge_cases.t @@ -0,0 +1,188 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +Check for repeated inheritance causing +a method conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base; + use Moose::Role; + + sub foo { 'Role::Base::foo' } + + package Role::Derived1; + use Moose::Role; + + with 'Role::Base'; + + package Role::Derived2; + use Moose::Role; + + with 'Role::Base'; + + package My::Test::Class1; + use Moose; + + ::is( ::exception { + with 'Role::Derived1', 'Role::Derived2'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base->meta->has_method('foo'), '... have the method foo as expected'); +ok(Role::Derived1->meta->has_method('foo'), '... have the method foo as expected'); +ok(Role::Derived2->meta->has_method('foo'), '... have the method foo as expected'); +ok(My::Test::Class1->meta->has_method('foo'), '... have the method foo as expected'); + +is(My::Test::Class1->foo, 'Role::Base::foo', '... got the right value from method'); + +=pod + +Check for repeated inheritance causing +a method conflict with method modifiers +(which is not really a conflict) + +=cut + +{ + package Role::Base2; + use Moose::Role; + + override 'foo' => sub { super() . ' -> Role::Base::foo' }; + + package Role::Derived3; + use Moose::Role; + + with 'Role::Base2'; + + package Role::Derived4; + use Moose::Role; + + with 'Role::Base2'; + + package My::Test::Class2::Base; + use Moose; + + sub foo { 'My::Test::Class2::Base' } + + package My::Test::Class2; + use Moose; + + extends 'My::Test::Class2::Base'; + + ::is( ::exception { + with 'Role::Derived3', 'Role::Derived4'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base2->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(Role::Derived3->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(Role::Derived4->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(My::Test::Class2->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class2->meta->get_method('foo'), 'Moose::Meta::Method::Overridden'); +ok(My::Test::Class2::Base->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class2::Base->meta->get_method('foo'), 'Class::MOP::Method'); + +is(My::Test::Class2::Base->foo, 'My::Test::Class2::Base', '... got the right value from method'); +is(My::Test::Class2->foo, 'My::Test::Class2::Base -> Role::Base::foo', '... got the right value from method'); + +=pod + +Check for repeated inheritance of the +same code. There are no conflicts with +before/around/after method modifiers. + +This tests around, but should work the +same for before/afters as well + +=cut + +{ + package Role::Base3; + use Moose::Role; + + around 'foo' => sub { 'Role::Base::foo(' . (shift)->() . ')' }; + + package Role::Derived5; + use Moose::Role; + + with 'Role::Base3'; + + package Role::Derived6; + use Moose::Role; + + with 'Role::Base3'; + + package My::Test::Class3::Base; + use Moose; + + sub foo { 'My::Test::Class3::Base' } + + package My::Test::Class3; + use Moose; + + extends 'My::Test::Class3::Base'; + + ::is( ::exception { + with 'Role::Derived5', 'Role::Derived6'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base3->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(Role::Derived5->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(Role::Derived6->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(My::Test::Class3->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class3->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(My::Test::Class3::Base->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class3::Base->meta->get_method('foo'), 'Class::MOP::Method'); + +is(My::Test::Class3::Base->foo, 'My::Test::Class3::Base', '... got the right value from method'); +is(My::Test::Class3->foo, 'Role::Base::foo(My::Test::Class3::Base)', '... got the right value from method'); + +=pod + +Check for repeated inheritance causing +a attr conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base4; + use Moose::Role; + + has 'foo' => (is => 'ro', default => 'Role::Base::foo'); + + package Role::Derived7; + use Moose::Role; + + with 'Role::Base4'; + + package Role::Derived8; + use Moose::Role; + + with 'Role::Base4'; + + package My::Test::Class4; + use Moose; + + ::is( ::exception { + with 'Role::Derived7', 'Role::Derived8'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base4->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived7->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived8->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(My::Test::Class4->meta->has_attribute('foo'), '... have the attribute foo as expected'); + +is(My::Test::Class4->new->foo, 'Role::Base::foo', '... got the right value from method'); + +done_testing; diff --git a/t/roles/role_consumers.t b/t/roles/role_consumers.t new file mode 100644 index 0000000..13707f3 --- /dev/null +++ b/t/roles/role_consumers.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; +} + +{ + package Foo; + use Moose; + with 'Foo::Role'; +} + +{ + package Bar; + use Moose; + extends 'Foo'; + with 'Bar::Role'; +} + +{ + package FooBar; + use Moose; + with 'Foo::Role', 'Bar::Role'; +} + +{ + package Foo::Role::User; + use Moose::Role; + with 'Foo::Role'; +} + +{ + package Foo::User; + use Moose; + with 'Foo::Role::User'; +} + +is_deeply([sort Foo::Role->meta->consumers], + ['Bar', 'Foo', 'Foo::Role::User', 'Foo::User', 'FooBar']); +is_deeply([sort Bar::Role->meta->consumers], + ['Bar', 'FooBar']); +is_deeply([sort Foo::Role::User->meta->consumers], + ['Foo::User']); + +done_testing; diff --git a/t/roles/role_exclusion.t b/t/roles/role_exclusion.t new file mode 100644 index 0000000..d6cb80a --- /dev/null +++ b/t/roles/role_exclusion.t @@ -0,0 +1,119 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +The idea and examples for this feature are taken +from the Fortress spec. + +http://research.sun.com/projects/plrg/fortress0903.pdf + +trait OrganicMolecule extends Molecule + excludes { InorganicMolecule } +end +trait InorganicMolecule extends Molecule end + +=cut + +{ + package Molecule; + use Moose::Role; + + package Molecule::Organic; + use Moose::Role; + + with 'Molecule'; + excludes 'Molecule::Inorganic'; + + package Molecule::Inorganic; + use Moose::Role; + + with 'Molecule'; +} + +ok(Molecule::Organic->meta->excludes_role('Molecule::Inorganic'), '... Molecule::Organic exludes Molecule::Inorganic'); +is_deeply( + [ Molecule::Organic->meta->get_excluded_roles_list() ], + [ 'Molecule::Inorganic' ], + '... Molecule::Organic exludes Molecule::Inorganic'); + +=pod + +Check some basic conflicts when combining +the roles into the same class + +=cut + +{ + package My::Test1; + use Moose; + + ::is( ::exception { + with 'Molecule::Organic'; + }, undef, '... adding the role (w/ excluded roles) okay' ); + + package My::Test2; + use Moose; + + ::like( ::exception { + with 'Molecule::Organic', 'Molecule::Inorganic'; + }, qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); + + package My::Test3; + use Moose; + + ::is( ::exception { + with 'Molecule::Organic'; + }, undef, '... adding the role (w/ excluded roles) okay' ); + + ::like( ::exception { + with 'Molecule::Inorganic'; + }, qr/Conflict detected: My::Test3 excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); +} + +ok(My::Test1->does('Molecule::Organic'), '... My::Test1 does Molecule::Organic'); +ok(My::Test1->does('Molecule'), '... My::Test1 does Molecule'); +ok(My::Test1->meta->excludes_role('Molecule::Inorganic'), '... My::Test1 excludes Molecule::Organic'); + +ok(!My::Test2->does('Molecule::Organic'), '... ! My::Test2 does Molecule::Organic'); +ok(!My::Test2->does('Molecule::Inorganic'), '... ! My::Test2 does Molecule::Inorganic'); + +ok(My::Test3->does('Molecule::Organic'), '... My::Test3 does Molecule::Organic'); +ok(My::Test3->does('Molecule'), '... My::Test1 does Molecule'); +ok(My::Test3->meta->excludes_role('Molecule::Inorganic'), '... My::Test3 excludes Molecule::Organic'); +ok(!My::Test3->does('Molecule::Inorganic'), '... ! My::Test3 does Molecule::Inorganic'); + +=pod + +Check some basic conflicts when combining +the roles into the a superclass + +=cut + +{ + package Methane; + use Moose; + + with 'Molecule::Organic'; + + package My::Test4; + use Moose; + + extends 'Methane'; + + ::like( ::exception { + with 'Molecule::Inorganic'; + }, qr/Conflict detected: My::Test4 excludes role \'Molecule::Inorganic\'/, '... cannot add exculded role into class which extends Methane' ); +} + +ok(Methane->does('Molecule::Organic'), '... Methane does Molecule::Organic'); +ok(My::Test4->isa('Methane'), '... My::Test4 isa Methane'); +ok(My::Test4->does('Molecule::Organic'), '... My::Test4 does Molecule::Organic'); +ok(My::Test4->meta->does_role('Molecule::Organic'), '... My::Test4 meat does_role Molecule::Organic'); +ok(My::Test4->meta->excludes_role('Molecule::Inorganic'), '... My::Test4 meta excludes Molecule::Organic'); +ok(!My::Test4->does('Molecule::Inorganic'), '... My::Test4 does Molecule::Inorganic'); + +done_testing; diff --git a/t/roles/role_exclusion_and_alias_bug.t b/t/roles/role_exclusion_and_alias_bug.t new file mode 100644 index 0000000..dc4b0a5 --- /dev/null +++ b/t/roles/role_exclusion_and_alias_bug.t @@ -0,0 +1,67 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package My::Role; + use Moose::Role; + + sub foo { "FOO" } + sub bar { "BAR" } +} + +{ + package My::Class; + use Moose; + + with 'My::Role' => { + -alias => { foo => 'baz', bar => 'gorch' }, + -excludes => ['foo', 'bar'], + }; +} + +{ + my $x = My::Class->new; + isa_ok($x, 'My::Class'); + does_ok($x, 'My::Role'); + + can_ok($x, $_) for qw[baz gorch]; + + ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; + + is($x->baz, 'FOO', '... got the right value'); + is($x->gorch, 'BAR', '... got the right value'); +} + +{ + package My::Role::Again; + use Moose::Role; + + with 'My::Role' => { + -alias => { foo => 'baz', bar => 'gorch' }, + -excludes => ['foo', 'bar'], + }; + + package My::Class::Again; + use Moose; + + with 'My::Role::Again'; +} + +{ + my $x = My::Class::Again->new; + isa_ok($x, 'My::Class::Again'); + does_ok($x, 'My::Role::Again'); + does_ok($x, 'My::Role'); + + can_ok($x, $_) for qw[baz gorch]; + + ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; + + is($x->baz, 'FOO', '... got the right value'); + is($x->gorch, 'BAR', '... got the right value'); +} + +done_testing; diff --git a/t/roles/role_for_combination.t b/t/roles/role_for_combination.t new file mode 100644 index 0000000..d4a1684 --- /dev/null +++ b/t/roles/role_for_combination.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; + +my $OPTS; +do { + package My::Singleton::Role; + use Moose::Role; + + sub foo { 'My::Singleton::Role' } + + package My::Role::Metaclass; + use Moose; + BEGIN { extends 'Moose::Meta::Role' }; + + sub _role_for_combination { + my ($self, $opts) = @_; + $OPTS = $opts; + return My::Singleton::Role->meta; + } + + package My::Special::Role; + use Moose::Role -metaclass => 'My::Role::Metaclass'; + + sub foo { 'My::Special::Role' } + + package My::Usual::Role; + use Moose::Role; + + sub bar { 'My::Usual::Role' } + + package My::Class; + use Moose; + + with ( + 'My::Special::Role' => { number => 1 }, + 'My::Usual::Role' => { number => 2 }, + ); +}; + +is(My::Class->foo, 'My::Singleton::Role', 'role_for_combination applied'); +is(My::Class->bar, 'My::Usual::Role', 'collateral role'); +is_deeply($OPTS, { number => 1 }); + +done_testing; diff --git a/t/roles/roles_and_method_cloning.t b/t/roles/roles_and_method_cloning.t new file mode 100644 index 0000000..1624a98 --- /dev/null +++ b/t/roles/roles_and_method_cloning.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Role::Foo; + use Moose::Role; + + sub foo { (caller(0))[3] } +} + +{ + package ClassA; + use Moose; + + with 'Role::Foo'; +} + +{ + my $meth = ClassA->meta->get_method('foo'); + ok( $meth, 'ClassA has a foo method' ); + isa_ok( $meth, 'Moose::Meta::Method' ); + is( $meth->original_method, Role::Foo->meta->get_method('foo'), + 'ClassA->foo was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'ClassA::foo', + 'fq name is ClassA::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +{ + package Role::Bar; + use Moose::Role; + with 'Role::Foo'; + + sub bar { } +} + +{ + my $meth = Role::Bar->meta->get_method('foo'); + ok( $meth, 'Role::Bar has a foo method' ); + is( $meth->original_method, Role::Foo->meta->get_method('foo'), + 'Role::Bar->foo was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'Role::Bar::foo', + 'fq name is Role::Bar::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +{ + package ClassB; + use Moose; + + with 'Role::Bar'; +} + +{ + my $meth = ClassB->meta->get_method('foo'); + ok( $meth, 'ClassB has a foo method' ); + is( $meth->original_method, Role::Bar->meta->get_method('foo'), + 'ClassA->foo was cloned from Role::Bar->foo' ); + is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'), + '... which in turn was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'ClassB::foo', + 'fq name is ClassA::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo"); + +is( ClassB->foo, 'Role::Foo::foo', 'ClassB::foo knows its name' ); +is( ClassA->foo, 'Role::Foo::foo', 'ClassA::foo knows its name' ); + +done_testing; diff --git a/t/roles/roles_and_req_method_edge_cases.t b/t/roles/roles_and_req_method_edge_cases.t new file mode 100644 index 0000000..601dbf1 --- /dev/null +++ b/t/roles/roles_and_req_method_edge_cases.t @@ -0,0 +1,277 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +NOTE: +A fair amount of these tests will likely be irrelevant +once we have more fine grained control over the class +building process. A lot of the edge cases tested here +are actually related to class construction order and +not any real functionality. +- SL + +Role which requires a method implemented +in another role as an override (it does +not remove the requirement) + +=cut + +{ + package Role::RequireFoo; + use strict; + use warnings; + use Moose::Role; + + requires 'foo'; + + package Role::ProvideFoo; + use strict; + use warnings; + use Moose::Role; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will not exist yet (but we will live)' ); + + override 'foo' => sub { 'Role::ProvideFoo::foo' }; +} + +is_deeply( + [ Role::ProvideFoo->meta->get_required_method_list ], + [ 'foo' ], + '... foo method is still required for Role::ProvideFoo'); + +=pod + +Role which requires a method implemented +in the consuming class as an override. +It will fail since method modifiers are +second class citizens. + +=cut + +{ + package Class::ProvideFoo::Base; + use Moose; + + sub foo { 'Class::ProvideFoo::Base::foo' } + + package Class::ProvideFoo::Override1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass' ); + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + package Class::ProvideFoo::Override2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, although it is overriden locally' ); + +} + +=pod + +Now same thing, but with a before +method modifier. + +=cut + +{ + package Class::ProvideFoo::Before1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass' ); + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + package Class::ProvideFoo::Before2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, although it is a before modifier locally' ); + + package Class::ProvideFoo::Before3; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists locally, and it is modified locally' ); + + package Class::ProvideFoo::Before4; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); + ::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__, + '... but the original method is from our package'); + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists in the symbol table (and we will live)' ); + +} + +=pod + +Now same thing, but with a method from an attribute +method modifier. + +=cut + +{ + + package Class::ProvideFoo::Attr1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass (but then overriden)' ); + + has 'foo' => (is => 'ro'); + + package Class::ProvideFoo::Attr2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + has 'foo' => (is => 'ro'); + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, and is an accessor' ); +} + +# ... +# a method required in a role, but then +# implemented in the superclass (as an +# attribute accessor too) + +{ + package Foo::Class::Base; + use Moose; + + has 'bar' => ( + isa => 'Int', + is => 'rw', + default => sub { 1 } + ); +} +{ + package Foo::Role; + use Moose::Role; + + requires 'bar'; + + has 'foo' => ( + isa => 'Int', + is => 'rw', + lazy => 1, + default => sub { (shift)->bar + 1 } + ); +} +{ + package Foo::Class::Child; + use Moose; + extends 'Foo::Class::Base'; + + ::is( ::exception { + with 'Foo::Role'; + }, undef, '... our role combined successfully' ); +} + +# a method required in a role and implemented in a superclass, with a method +# modifier in the subclass. this should live, but dies in 0.26 -- hdp, +# 2007-10-11 + +{ + package Bar::Class::Base; + use Moose; + + sub bar { "hello!" } +} +{ + package Bar::Role; + use Moose::Role; + requires 'bar'; +} +{ + package Bar::Class::Child; + use Moose; + extends 'Bar::Class::Base'; + after bar => sub { "o noes" }; + # technically we could run lives_ok here, too, but putting it into a + # grandchild class makes it more obvious why this matters. +} +{ + package Bar::Class::Grandchild; + use Moose; + extends 'Bar::Class::Child'; + ::is( ::exception { + with 'Bar::Role'; + }, undef, 'required method exists in superclass as non-modifier, so we live' ); +} + +{ + package Bar2::Class::Base; + use Moose; + + sub bar { "hello!" } +} +{ + package Bar2::Role; + use Moose::Role; + requires 'bar'; +} +{ + package Bar2::Class::Child; + use Moose; + extends 'Bar2::Class::Base'; + override bar => sub { "o noes" }; + # technically we could run lives_ok here, too, but putting it into a + # grandchild class makes it more obvious why this matters. +} +{ + package Bar2::Class::Grandchild; + use Moose; + extends 'Bar2::Class::Child'; + ::is( ::exception { + with 'Bar2::Role'; + }, undef, 'required method exists in superclass as non-modifier, so we live' ); +} + +done_testing; diff --git a/t/roles/roles_applied_in_create.t b/t/roles/roles_applied_in_create.t new file mode 100644 index 0000000..9f617ad --- /dev/null +++ b/t/roles/roles_applied_in_create.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose::Meta::Class; +use Moose::Util; + +use lib 't/lib'; + + +# Note that this test passed (pre svn #5543) if we inlined the role +# definitions in this file, as it was very timing sensitive. +is( exception { + my $builder_meta = Moose::Meta::Class->create( + 'YATTA' => ( + superclass => 'Moose::Meta::Class', + roles => [qw( Role::Interface Role::Child )], + ) + ); +}, undef, 'Create a new class with several roles' ); + +done_testing; diff --git a/t/roles/run_time_role_composition.t b/t/roles/run_time_role_composition.t new file mode 100644 index 0000000..c847df3 --- /dev/null +++ b/t/roles/run_time_role_composition.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util qw(blessed); + + +=pod + +This test can be used as a basis for the runtime role composition. +Apparently it is not as simple as just making an anon class. One of +the problems is the way that anon classes are DESTROY-ed, which is +not very compatible with how instances are dealt with. + +=cut + +{ + package Bark; + use Moose::Role; + + sub talk { 'woof' } + + package Sleeper; + use Moose::Role; + + sub sleep { 'snore' } + sub talk { 'zzz' } + + package My::Class; + use Moose; + + sub sleep { 'nite-nite' } +} + +my $obj = My::Class->new; +isa_ok($obj, 'My::Class'); + +my $obj2 = My::Class->new; +isa_ok($obj2, 'My::Class'); + +{ + ok(!$obj->can( 'talk' ), "... the role is not composed yet"); + + ok(!$obj->does('Bark'), '... we do not do any roles yet'); + + Bark->meta->apply($obj); + + ok($obj->does('Bark'), '... we now do the Bark role'); + ok(!My::Class->does('Bark'), '... the class does not do the Bark role'); + + isa_ok($obj, 'My::Class'); + isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class'); + + ok(!My::Class->can('talk'), "... the role is not composed at the class level"); + ok($obj->can('talk'), "... the role is now composed at the object level"); + + is($obj->talk, 'woof', '... got the right return value for the newly composed method'); +} + +{ + ok(!$obj2->does('Sleeper'), '... we do not do any roles yet'); + + Sleeper->meta->apply($obj2); + + ok($obj2->does('Sleeper'), '... we now do the Sleeper role'); + isnt(blessed($obj), blessed($obj2), '... they DO NOT share the same anon-class/role thing'); +} + +{ + is($obj->sleep, 'nite-nite', '... the original method responds as expected'); + + ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role'); + + Sleeper->meta->apply($obj); + + ok($obj->does('Bark'), '... we still do the Bark role'); + ok($obj->does('Sleeper'), '... we now do the Sleeper role too'); + + ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role'); + + isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); + + isa_ok($obj, 'My::Class'); + + is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected'); + + is($obj->sleep, 'snore', '... got the right return value for the newly composed method'); + is($obj->talk, 'zzz', '... got the right return value for the newly composed method'); +} + +{ + ok(!$obj2->does('Bark'), '... we do not do Bark yet'); + + Bark->meta->apply($obj2); + + ok($obj2->does('Bark'), '... we now do the Bark role'); + isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); +} + +# test that anon classes are equivalent after role composition in the same order +{ + foreach ($obj, $obj2) { + $_ = My::Class->new; + Bark->meta->apply($_); + Sleeper->meta->apply($_); + } + is(blessed($obj), blessed($obj2), '... they now share the same anon-class/role thing'); +} + +done_testing; diff --git a/t/roles/runtime_roles_and_attrs.t b/t/roles/runtime_roles_and_attrs.t new file mode 100644 index 0000000..ef5c06c --- /dev/null +++ b/t/roles/runtime_roles_and_attrs.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Dog; + use Moose::Role; + + sub talk { 'woof' } + + has fur => ( + isa => "Str", + is => "rw", + default => "dirty", + ); + + package Foo; + use Moose; + + has 'dog' => ( + is => 'rw', + does => 'Dog', + ); +} + +my $obj = Foo->new; +isa_ok($obj, 'Foo'); + +ok(!$obj->can( 'talk' ), "... the role is not composed yet"); +ok(!$obj->can( 'fur' ), 'ditto'); +ok(!$obj->does('Dog'), '... we do not do any roles yet'); + +isnt( exception { + $obj->dog($obj) +}, undef, '... and setting the accessor fails (not a Dog yet)' ); + +Dog->meta->apply($obj); + +ok($obj->does('Dog'), '... we now do the Bark role'); +ok($obj->can('talk'), "... the role is now composed at the object level"); +ok($obj->can('fur'), "it has fur"); + +is($obj->talk, 'woof', '... got the right return value for the newly composed method'); + +is( exception { + $obj->dog($obj) +}, undef, '... and setting the accessor is okay' ); + +is($obj->fur, "dirty", "role attr initialized"); + +done_testing; diff --git a/t/roles/runtime_roles_and_nonmoose.t b/t/roles/runtime_roles_and_nonmoose.t new file mode 100644 index 0000000..4365eb6 --- /dev/null +++ b/t/roles/runtime_roles_and_nonmoose.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Dog; + use Moose::Role; + + sub talk { 'woof' } + + package Foo; + use Moose; + + has 'dog' => ( + is => 'rw', + does => 'Dog', + ); + + no Moose; + + package Bar; + + sub new { + return bless {}, shift; + } +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +ok(!$bar->can( 'talk' ), "... the role is not composed yet"); + +isnt( exception { + $foo->dog($bar) +}, undef, '... and setting the accessor fails (not a Dog yet)' ); + +Dog->meta->apply($bar); + +ok($bar->can('talk'), "... the role is now composed at the object level"); + +is($bar->talk, 'woof', '... got the right return value for the newly composed method'); + +is( exception { + $foo->dog($bar) +}, undef, '... and setting the accessor is okay' ); + +done_testing; diff --git a/t/roles/runtime_roles_w_params.t b/t/roles/runtime_roles_w_params.t new file mode 100644 index 0000000..6d5353f --- /dev/null +++ b/t/roles/runtime_roles_w_params.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + has 'bar' => (is => 'ro'); + + package Bar; + use Moose::Role; + + has 'baz' => (is => 'ro', default => 'BAZ'); +} + +# normal ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'BAZ', '... got the expect value'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo, (rebless_params => { baz => 'FOO-BAZ' })) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo, (rebless_params => { bar => 'FOO-BAR', baz => 'FOO-BAZ' })) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); +} + +done_testing; diff --git a/t/roles/use_base_does.t b/t/roles/use_base_does.t new file mode 100644 index 0000000..a3d5b41 --- /dev/null +++ b/t/roles/use_base_does.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Foo; + use Moose; + + with 'Foo::Role'; +} + +{ + package Foo::Sub; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub2; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub3; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub4; + use parent -norequire => 'Foo'; +} + +ok(Foo::Sub->does('Foo::Role'), "class does Foo::Role"); +ok(Foo::Sub2->new->does('Foo::Role'), "object does Foo::Role"); +ok(!Foo::Sub3->does('Bar::Role'), "class doesn't do Bar::Role"); +ok(!Foo::Sub4->new->does('Bar::Role'), "object doesn't do Bar::Role"); + +done_testing; diff --git a/t/test_moose/test_moose.t b/t/test_moose/test_moose.t new file mode 100644 index 0000000..e277cfa --- /dev/null +++ b/t/test_moose/test_moose.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + use_ok('Test::Moose'); +} + +done_testing; diff --git a/t/test_moose/test_moose_does_ok.t b/t/test_moose/test_moose_does_ok.t new file mode 100644 index 0000000..9ba5b68 --- /dev/null +++ b/t/test_moose/test_moose_does_ok.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose::Role; +} + +{ + package Bar; + use Moose; + + with qw/Foo/; +} + +{ + package Baz; + use Moose; +} + +# class ok + +test_out('ok 1 - does_ok class'); + +does_ok('Bar','Foo','does_ok class'); + +# class fail + +test_out ('not ok 2 - does_ok class fail'); +test_fail (+2); + +does_ok('Baz','Foo','does_ok class fail'); + +# object ok + +my $bar = Bar->new; + +test_out ('ok 3 - does_ok object'); + +does_ok ($bar,'Foo','does_ok object'); + +# object fail + +my $baz = Baz->new; + +test_out ('not ok 4 - does_ok object fail'); +test_fail (+2); + +does_ok ($baz,'Foo','does_ok object fail'); + +test_test ('does_ok'); + +done_testing; diff --git a/t/test_moose/test_moose_has_attribute_ok.t b/t/test_moose/test_moose_has_attribute_ok.t new file mode 100644 index 0000000..9e77dd4 --- /dev/null +++ b/t/test_moose/test_moose_has_attribute_ok.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose; + + has 'foo', is => 'bare'; +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + has 'bar', is => 'bare'; +} + + +test_out('ok 1 - ... has_attribute_ok(Foo, foo) passes'); + +has_attribute_ok('Foo', 'foo', '... has_attribute_ok(Foo, foo) passes'); + +test_out ('not ok 2 - ... has_attribute_ok(Foo, bar) fails'); +test_fail (+2); + +has_attribute_ok('Foo', 'bar', '... has_attribute_ok(Foo, bar) fails'); + +test_out('ok 3 - ... has_attribute_ok(Bar, foo) passes'); + +has_attribute_ok('Bar', 'foo', '... has_attribute_ok(Bar, foo) passes'); + +test_out('ok 4 - ... has_attribute_ok(Bar, bar) passes'); + +has_attribute_ok('Bar', 'bar', '... has_attribute_ok(Bar, bar) passes'); + +test_test ('has_attribute_ok'); + +done_testing; diff --git a/t/test_moose/test_moose_meta_ok.t b/t/test_moose/test_moose_meta_ok.t new file mode 100644 index 0000000..1556379 --- /dev/null +++ b/t/test_moose/test_moose_meta_ok.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose; +} + +{ + package Bar; +} + +test_out('ok 1 - ... meta_ok(Foo) passes'); + +meta_ok('Foo', '... meta_ok(Foo) passes'); + +test_out ('not ok 2 - ... meta_ok(Bar) fails'); +test_fail (+2); + +meta_ok('Bar', '... meta_ok(Bar) fails'); + +test_test ('meta_ok'); + +done_testing; diff --git a/t/test_moose/with_immutable.t b/t/test_moose/with_immutable.t new file mode 100644 index 0000000..6536e70 --- /dev/null +++ b/t/test_moose/with_immutable.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose; +} + +{ + package Bar; + use Moose; +} + +package main; + +test_out("ok 1", "not ok 2"); +test_fail(+2); +my $ret = with_immutable { + ok(Foo->meta->is_mutable); +} qw(Foo); +test_test('with_immutable failure'); +ok(!$ret, "one of our tests failed"); + +test_out("ok 1", "ok 2"); +$ret = with_immutable { + ok(Bar->meta->find_method_by_name('new')); +} qw(Bar); +test_test('with_immutable success'); +ok($ret, "all tests succeeded"); + +done_testing; diff --git a/t/todo_tests/exception_reflects_failed_constraint.t b/t/todo_tests/exception_reflects_failed_constraint.t new file mode 100644 index 0000000..6375fab --- /dev/null +++ b/t/todo_tests/exception_reflects_failed_constraint.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +# In the case where a child type constraint's parent constraint fails, +# the exception should reference the parent type constraint that actually +# failed instead of always referencing the child'd type constraint + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +is( exception { + subtype 'ParentConstraint' => as 'Str' => where {0}; +}, undef, 'specified parent type constraint' ); + +my $tc; +is( exception { + $tc = subtype 'ChildConstraint' => as 'ParentConstraint' => where {1}; +}, undef, 'specified child type constraint' ); + +{ + my $errmsg = $tc->validate(); + + TODO: { + local $TODO = 'Not yet supported'; + ok($errmsg !~ /Validation failed for 'ChildConstraint'/, 'exception references failing parent constraint'); + }; +} + +done_testing; diff --git a/t/todo_tests/immutable_n_around.t b/t/todo_tests/immutable_n_around.t new file mode 100644 index 0000000..04d3980 --- /dev/null +++ b/t/todo_tests/immutable_n_around.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; + +# if make_immutable is removed from the following code the tests pass + +{ + package Foo; + use Moose; + + has foo => ( is => "ro" ); + + package Bar; + use Moose; + + extends qw(Foo); + + around new => sub { + my $next = shift; + my ( $self, @args ) = @_; + $self->$next( foo => 42 ); + }; + + package Gorch; + use Moose; + + extends qw(Bar); + + package Zoink; + use Moose; + + extends qw(Gorch); + +} + +my @classes = qw(Foo Bar Gorch Zoink); + +tests: { + is( Foo->new->foo, undef, "base class (" . (Foo->meta->is_immutable ? "immutable" : "mutable") . ")" ); + is( Bar->new->foo, 42, "around new called on Bar->new (" . (Bar->meta->is_immutable ? "immutable" : "mutable") . ")" ); + is( Gorch->new->foo, 42, "around new called on Gorch->new (" . (Gorch->meta->is_immutable ? "immutable" : "mutable") . ")" ); + is( Zoink->new->foo, 42, "around new called Zoink->new (" . (Zoink->meta->is_immutable ? "immutable" : "mutable") . ")" ); + + if ( @classes ) { + local $SIG{__WARN__} = sub {}; + ( shift @classes )->meta->make_immutable; + redo tests; + } +} + +done_testing; diff --git a/t/todo_tests/moose_and_threads.t b/t/todo_tests/moose_and_threads.t new file mode 100644 index 0000000..a0316fe --- /dev/null +++ b/t/todo_tests/moose_and_threads.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +See this for some details: + +http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=476579 + +Here is the basic test case, it segfaults, so I am going +to leave it commented out. Basically it seems that there +is some bad interaction between the ??{} construct that +is used in the "parser" for type definitions and threading +so probably the fix would involve removing the ??{} usage +for something else. + +use threads; + +{ + package Foo; + use Moose; + has "bar" => (is => 'rw', isa => "Str | Num"); +} + +my $thr = threads->create(sub {}); +$thr->join(); + +=cut + +{ + local $TODO = 'This is just a stub for the test, see the POD'; + fail('Moose type constraints and threads dont get along'); +} + +done_testing; diff --git a/t/todo_tests/replacing_super_methods.t b/t/todo_tests/replacing_super_methods.t new file mode 100644 index 0000000..eef494a --- /dev/null +++ b/t/todo_tests/replacing_super_methods.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +my ($super_called, $sub_called, $new_super_called) = (0, 0, 0); +{ + package Foo; + use Moose; + + sub foo { $super_called++ } +} + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; + + override foo => sub { + $sub_called++; + super(); + }; +} + +Foo::Sub->new->foo; +is($super_called, 1, "super called"); +is($new_super_called, 0, "new super not called"); +is($sub_called, 1, "sub called"); + +($super_called, $sub_called, $new_super_called) = (0, 0, 0); + +Foo->meta->add_method(foo => sub { + $new_super_called++; +}); + +Foo::Sub->new->foo; +{ local $TODO = "super doesn't get replaced"; +is($super_called, 0, "super not called"); +is($new_super_called, 1, "new super called"); +} +is($sub_called, 1, "sub called"); + +done_testing; diff --git a/t/todo_tests/required_role_accessors.t b/t/todo_tests/required_role_accessors.t new file mode 100644 index 0000000..d25f6e8 --- /dev/null +++ b/t/todo_tests/required_role_accessors.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo::API; + use Moose::Role; + + requires 'foo'; +} + +{ + package Foo; + use Moose::Role; + + has foo => (is => 'ro'); + + with 'Foo::API'; +} + +{ + package Foo::Class; + use Moose; + { our $TODO; local $TODO = "role accessors don't satisfy other role requires"; + ::is( ::exception { with 'Foo' }, undef, 'requirements are satisfied properly' ); + } +} + +{ + package Bar; + use Moose::Role; + + requires 'baz'; + + has bar => (is => 'ro'); +} + +{ + package Baz; + use Moose::Role; + + requires 'bar'; + + has baz => (is => 'ro'); +} + +{ + package BarBaz; + use Moose; + + { our $TODO; local $TODO = "role accessors don't satisfy other role requires"; + ::is( ::exception { with qw(Bar Baz) }, undef, 'requirements are satisfied properly' ); + } +} + +done_testing; diff --git a/t/todo_tests/role_attr_methods_original_package.t b/t/todo_tests/role_attr_methods_original_package.t new file mode 100644 index 0000000..ca0f7ce --- /dev/null +++ b/t/todo_tests/role_attr_methods_original_package.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More 0.88; + +{ + package Some::Role; + use Moose::Role; + + has 'thing' => ( + is => 'ro', + ); + + sub foo { 42 } +} + +{ + package Some::Class; + use Moose; + + with 'Some::Role'; +} + +my $attr = Some::Class->meta()->get_attribute('thing'); + +# See RT #84563 +for my $method ( @{ $attr->associated_methods() } ) { +TODO: { + local $TODO + = q{Methods generated from role-provided attributes don't know their original package}; + is( + $method->original_package_name(), + 'Some::Role', + 'original_package_name for methods generated from role attribute should match the role' + ); + } +} + +is( + Some::Class->meta()->get_method('foo')->original_package_name(), + 'Some::Role', + 'original_package_name for methods from role should match the role' +); + +done_testing(); diff --git a/t/todo_tests/role_insertion_order.t b/t/todo_tests/role_insertion_order.t new file mode 100644 index 0000000..151c26e --- /dev/null +++ b/t/todo_tests/role_insertion_order.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Role; + use Moose::Role; + has 'a' => (is => 'ro'); + has 'b' => (is => 'ro'); + has 'c' => (is => 'ro'); +} + +{ + package Foo; + use Moose; + has 'd' => (is => 'ro'); + with 'Foo::Role'; + has 'e' => (is => 'ro'); +} + +my %role_insertion_order = ( + a => 0, + b => 1, + c => 2, +); + +is_deeply({ map { $_->name => $_->insertion_order } map { Foo::Role->meta->get_attribute($_) } Foo::Role->meta->get_attribute_list }, \%role_insertion_order, "right insertion order within the role"); + +my %class_insertion_order = ( + d => 0, + a => 1, + b => 2, + c => 3, + e => 4, +); + +{ local $TODO = "insertion order is lost during role application"; +is_deeply({ map { $_->name => $_->insertion_order } Foo->meta->get_all_attributes }, \%class_insertion_order, "right insertion order within the class"); +} + +done_testing; diff --git a/t/todo_tests/various_role_features.t b/t/todo_tests/various_role_features.t new file mode 100644 index 0000000..b8a3c4a --- /dev/null +++ b/t/todo_tests/various_role_features.t @@ -0,0 +1,271 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +sub req_or_has ($$) { + my ( $role, $method ) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + if ( $role ) { + ok( + $role->has_method($method) || $role->requires_method($method), + $role->name . " has or requires method $method" + ); + } else { + fail("role has or requires method $method"); + } +} + +{ + package Bar; + use Moose::Role; + + # this role eventually adds three methods, qw(foo bar xxy), but only one is + # known when it's still a role + + has foo => ( is => "rw" ); + + has gorch => ( reader => "bar" ); + + sub xxy { "BAAAD" } + + package Gorch; + use Moose::Role; + + # similarly this role gives attr and gorch_method + + has attr => ( is => "rw" ); + + sub gorch_method { "gorch method" } + + around dandy => sub { shift->(@_) . "bar" }; + + package Quxx; + use Moose; + + sub dandy { "foo" } + + # this object will be used in an attr of Foo to test that Foo can do the + # Gorch interface + + with qw(Gorch); + + package Dancer; + use Moose::Role; + + requires "twist"; + + package Dancer::Ballerina; + use Moose; + + with qw(Dancer); + + sub twist { } + + sub pirouette { } + + package Dancer::Robot; + use Moose::Role; + + # this doesn't fail but it produces a requires in the role + # the order doesn't matter + has twist => ( is => "rw" ); + ::is( ::exception { with qw(Dancer) }, undef ); + + package Dancer::Something; + use Moose; + + # this fail even though the method already exists + + has twist => ( is => "rw" ); + + { + ::is( ::exception { with qw(Dancer) }, undef ); + } + + package Dancer::80s; + use Moose; + + # this should pass because ::Robot has the attribute to fill in the requires + # but due to the deferrence logic that doesn't actually work + { + local our $TODO = "attribute accessor in role doesn't satisfy role requires"; + ::is( ::exception { with qw(Dancer::Robot) }, undef ); + } + + package Foo; + use Moose; + + with qw(Bar); + + has oink => ( + is => "rw", + handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation? + default => sub { Quxx->new }, + ); + + has dancer => ( + is => "rw", + does => "Dancer", + handles => "Dancer", + default => sub { Dancer::Ballerina->new }, + ); + + sub foo { 42 } + + sub bar { 33 } + + sub xxy { 7 } + + package Tree; + use Moose::Role; + + has bark => ( is => "rw" ); + + package Dog; + use Moose::Role; + + sub bark { warn "woof!" }; + + package EntPuppy; + use Moose; + + { + local our $TODO = "attrs and methods from a role should clash"; + ::isnt( ::exception { with qw(Tree Dog) }, undef ); + } +} + +# these fail because of the deferral logic winning over actual methods +# this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack +# we've been doing for a long while, though I doubt people relied on it for +# anything other than fulfilling 'requires' +{ + local $TODO = "attributes from role overwrite class methods"; + is( Foo->new->foo, 42, "attr did not zap overriding method" ); + is( Foo->new->bar, 33, "attr did not zap overriding method" ); +} +is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh + +# these pass, simple delegate +# mostly they are here to contrast the next blck +can_ok( Foo->new->oink, "dandy" ); +can_ok( Foo->new->oink, "attr" ); +can_ok( Foo->new->oink, "gorch_method" ); + +ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" ); + + +# these are broken because 'attr' is not technically part of the interface +can_ok( Foo->new, "gorch_method" ); +{ + local $TODO = "accessor methods from a role are omitted in handles role"; + can_ok( Foo->new, "attr" ); +} + +{ + local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; + ok( Foo->new->does("Gorch"), "Foo does Gorch" ); +} + + +# these work +can_ok( Foo->new->dancer, "pirouette" ); +can_ok( Foo->new->dancer, "twist" ); + +can_ok( Foo->new, "twist" ); +ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" ); + +{ + local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; + ok( Foo->new->does("Dancer") ); +} + + + + +my $gorch = Gorch->meta; + +isa_ok( $gorch, "Moose::Meta::Role" ); + +ok( $gorch->has_attribute("attr"), "has attribute 'attr'" ); +isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Role::Attribute" ); + +req_or_has($gorch, "gorch_method"); +ok( $gorch->has_method("gorch_method"), "has_method gorch_method" ); +ok( !$gorch->requires_method("gorch_method"), "requires gorch method" ); +isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" ); + +{ + local $TODO = "method modifier doesn't yet create a method requirement or meta object"; + req_or_has($gorch, "dandy" ); + + # this specific test is maybe not backwards compat, but in theory it *does* + # require that method to exist + ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" ); +} + +{ + local $TODO = "attribute related methods are not yet known by the role"; + # we want this to be a part of the interface, somehow + req_or_has($gorch, "attr"); + ok( $gorch->has_method("attr"), "has_method attr" ); + isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method" ); + isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method::Accessor" ); +} + +my $robot = Dancer::Robot->meta; + +isa_ok( $robot, "Moose::Meta::Role" ); + +ok( $robot->has_attribute("twist"), "has attr 'twist'" ); +isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Role::Attribute" ); + +{ + req_or_has($robot, "twist"); + + local $TODO = "attribute related methods are not yet known by the role"; + ok( $robot->has_method("twist"), "has twist method" ); + isa_ok( $robot->get_method("twist"), "Moose::Meta::Method" ); + isa_ok( $robot->get_method("twist"), "Moose::Meta::Method::Accessor" ); +} + +done_testing; + +__END__ + +I think Attribute needs to be refactored in some way to better support roles. + +There are several possible ways to do this, all of them seem plausible to me. + +The first approach would be to change the attribute class to allow it to be +queried about the methods it would install. + +Then we instantiate the attribute in the role, and instead of deferring the +arguments, we just make an C<unpack>ish method. + +Then we can interrogate the attr when adding it to the role, and generate stub +methods for all the methods it would produce. + +A second approach is kinda like the Immutable hack: wrap the attr in an +anonmyous class that disables part of its interface. + +A third method would be to create an Attribute::Partial object that would +provide a more role-ish behavior, and to do this independently of the actual +Attribute class. + +Something similar can be done for method modifiers, but I think that's even simpler. + + + +The benefits of doing this are: + +* Much better introspection of roles + +* More correctness in many cases (in my opinion anyway) + +* More roles are more usable as interface declarations, without having to split + them into two pieces (one for the interface with a bunch of requires(), and + another for the actual impl with the problematic attrs (and stub methods to + fix the accessors) and method modifiers (dunno if this can even work at all) diff --git a/t/todo_tests/wrong-inner.t b/t/todo_tests/wrong-inner.t new file mode 100644 index 0000000..5160ca4 --- /dev/null +++ b/t/todo_tests/wrong-inner.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Test::More; + +# see RT#89397 + +{ + package A; + use Moose; + sub run { + my $self = shift; + inner(); + $self->cleanup; + } + sub cleanup { + inner(); + } +} + +{ + package B; + our $run; + use Moose; + extends 'A'; + augment run => sub { + my $self = shift; + $run++; + }; +} + +B->new->run(); + +local $TODO = 'wtf is going on here??'; +is($B::run, 1, 'B::run is only called once'); + +done_testing; diff --git a/t/type_constraints/advanced_type_creation.t b/t/type_constraints/advanced_type_creation.t new file mode 100644 index 0000000..b12a75d --- /dev/null +++ b/t/type_constraints/advanced_type_creation.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; + +## Containers in unions ... + +# Array of Ints or Strings + +my $array_of_ints_or_strings = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int|Str]'); +isa_ok($array_of_ints_or_strings, 'Moose::Meta::TypeConstraint::Parameterized'); + +ok($array_of_ints_or_strings->check([ 1, 'two', 3 ]), '... this passed the type check'); +ok($array_of_ints_or_strings->check([ 1, 2, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_strings->check([ 'one', 'two', 'three' ]), '... this passed the type check'); + +ok(!$array_of_ints_or_strings->check([ 1, [], 'three' ]), '... this didnt pass the type check'); + +$r->add_type_constraint($array_of_ints_or_strings); + +# Array of Ints or HashRef + +my $array_of_ints_or_hash_ref = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int | HashRef]'); +isa_ok($array_of_ints_or_hash_ref, 'Moose::Meta::TypeConstraint::Parameterized'); + +ok($array_of_ints_or_hash_ref->check([ 1, {}, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_hash_ref->check([ 1, 2, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_hash_ref->check([ {}, {}, {} ]), '... this passed the type check'); + +ok(!$array_of_ints_or_hash_ref->check([ {}, [], 3 ]), '... this didnt pass the type check'); + +$r->add_type_constraint($array_of_ints_or_hash_ref); + +# union of Arrays of Str | Int or Arrays of Int | Hash + +# we can't build this using the simplistic parser +# we have, so we have to do it by hand - SL + +my $pure_insanity = Moose::Util::TypeConstraints::create_type_constraint_union('ArrayRef[Int|Str] | ArrayRef[Int | HashRef]'); +isa_ok($pure_insanity, 'Moose::Meta::TypeConstraint::Union'); + +ok($pure_insanity->check([ 1, {}, 3 ]), '... this passed the type check'); +ok($pure_insanity->check([ 1, 'Str', 3 ]), '... this passed the type check'); + +ok(!$pure_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check'); +ok(!$pure_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check'); + +## Nested Containers ... + +# Array of Ints + +my $array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int]'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); +ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); +ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); + +ok(!$array_of_ints->check(1), '... 1 failed successfully'); +ok(!$array_of_ints->check({}), '... {} failed successfully'); +ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Array of Array of Ints + +my $array_of_array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[Int]]'); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ 4, 5, 6 ]] +), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); +ok(!$array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ qw/foo bar/ ]] +), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); + +# Array of Array of Array of Ints + +my $array_of_array_of_array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[ArrayRef[Int]]]'); +isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_array_of_array_of_ints->check( + [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] +), '... [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] passed successfully'); +ok(!$array_of_array_of_array_of_ints->check( + [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] +), '... [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] failed successfully'); + +done_testing; diff --git a/t/type_constraints/class_subtypes.t b/t/type_constraints/class_subtypes.t new file mode 100644 index 0000000..bc90209 --- /dev/null +++ b/t/type_constraints/class_subtypes.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint; + + +## Create a subclass with a custom method + +{ + package Test::Moose::Meta::TypeConstraint::AnySubType; + use Moose; + extends 'Moose::Meta::TypeConstraint'; + + sub my_custom_method { + return 1; + } +} + +my $Int = find_type_constraint('Int'); +ok $Int, 'Got a good type constraint'; + +my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({ + name => "Test::Moose::Meta::TypeConstraint::AnySubType" , + parent => $Int, +}); + +ok $parent, 'Created type constraint'; +ok $parent->check(1), 'Correctly passed'; +ok ! $parent->check('a'), 'correctly failed'; +ok $parent->my_custom_method, 'found the custom method'; + +my $subtype1 = subtype 'another_subtype' => as $parent; + +ok $subtype1, 'Created type constraint'; +ok $subtype1->check(1), 'Correctly passed'; +ok ! $subtype1->check('a'), 'correctly failed'; +ok $subtype1->my_custom_method, 'found the custom method'; + + +my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 }; + +ok $subtype2, 'Created type constraint'; +ok $subtype2->check(1), 'Correctly passed'; +ok ! $subtype2->check('a'), 'correctly failed'; +ok ! $subtype2->check(100), 'correctly failed'; + +ok $subtype2->my_custom_method, 'found the custom method'; + + +{ + package Foo; + + use Moose; +} + +{ + package Bar; + + use Moose; + + extends 'Foo'; +} + +{ + package Baz; + + use Moose; +} + +my $foo = class_type 'Foo'; +my $isa_foo = subtype 'IsaFoo' => as $foo; + +ok $isa_foo, 'Created subtype of Foo type'; +ok $isa_foo->check( Foo->new ), 'Foo passes check'; +ok $isa_foo->check( Bar->new ), 'Bar passes check'; +ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check'; +like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' with value .*Baz.* \(not isa Foo\)/, 'Better validation message'; + +# Maybe in the future this *should* inherit? +like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' with value .*Baz.*/, "Subtypes do not automatically inherit parent type's message"; + + +# Implicit types +{ + package Quux; + + use Moose; + + has age => ( + isa => 'Positive', + is => 'bare', + ); +} + +like( exception { + Quux->new(age => 3) +}, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); + +is( exception { + Quux->new(age => (bless {}, 'Positive')); +}, undef ); + +eval " + package Positive; + use Moose; +"; + +like( exception { + Quux->new(age => 3) +}, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); + +is( exception { + Quux->new(age => Positive->new) +}, undef ); + +class_type 'Negative' => message { "$_ is not a Negative Nancy" }; + +{ + package Quux::Ier; + + use Moose; + + has age => ( + isa => 'Negative', + is => 'bare', + ); +} + +like( exception { + Quux::Ier->new(age => 3) +}, qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy / ); + +is( exception { + Quux::Ier->new(age => (bless {}, 'Negative')) +}, undef ); + +done_testing; diff --git a/t/type_constraints/class_type_constraint.t b/t/type_constraints/class_type_constraint.t new file mode 100644 index 0000000..c4f4afc --- /dev/null +++ b/t/type_constraints/class_type_constraint.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Gorch; + use Moose; + + package Bar; + use Moose; + + package Foo; + use Moose; + + extends qw(Bar Gorch); + +} + +is( exception { class_type 'Beep' }, undef, 'class_type keyword works' ); +is( exception { class_type('Boop', message { "${_} is not a Boop" }) }, undef, 'class_type keywork works with message' ); + +{ + my $type = find_type_constraint("Foo"); + + is( $type->class, "Foo", "class attribute" ); + + ok( !$type->is_subtype_of('Foo'), "Foo is not subtype of Foo" ); + ok( !$type->is_subtype_of($type), '$foo_type is not subtype of $foo_type' ); + + ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); + + ok( $type->is_subtype_of("Bar"), "subtype of bar" ); + + ok( $type->is_subtype_of("Object"), "subtype of Object" ); + + ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of undefined type" ); + ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of undefined type" ); + + ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" ); + ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" ); + ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch"); + + ok( find_type_constraint("Beep")->check( bless {} => 'Beep' ), "Beep passes Beep" ); + my $boop = find_type_constraint("Boop"); + ok( $boop->has_message, 'Boop has a message'); + my $error = $boop->get_message(Foo->new); + like( $error, qr/is not a Boop/, 'boop gives correct error message'); + + + ok( $type->equals($type), "equals self" ); + ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Foo" )), "equals anon constraint of same value" ); + ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "Oink", class => "Foo" )), "equals differently named constraint of same value" ); + ok( !$type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" ); + ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" ); +} + +{ + is( exception { class_type 'FooType', { class => 'Foo' } }, undef, 'class_type keyword with custom type name' ); + my $type = find_type_constraint('FooType'); + is( $type->class, 'Foo', "class attribute" ); + ok( !$type->is_subtype_of('Foo'), "FooType is not subtype of Foo" ); + ok( !$type->is_subtype_of($type), '$foo_type is not subtype of $foo_type' ); +} + + +{ + package Parent; + sub parent { } +} + +{ + package Child; + use parent -norequire => 'Parent'; +} + +{ + my $parent = Moose::Meta::TypeConstraint::Class->new( + name => 'Parent', + class => 'Parent', + ); + ok($parent->is_a_type_of('Parent')); + ok(!$parent->is_subtype_of('Parent')); + ok($parent->is_a_type_of($parent)); + ok(!$parent->is_subtype_of($parent)); + + my $child = Moose::Meta::TypeConstraint::Class->new( + name => 'Child', + class => 'Child', + ); + ok($child->is_a_type_of('Child')); + ok(!$child->is_subtype_of('Child')); + ok($child->is_a_type_of($child)); + ok(!$child->is_subtype_of($child)); + ok($child->is_a_type_of('Parent')); + ok($child->is_subtype_of('Parent')); + ok($child->is_a_type_of($parent)); + ok($child->is_subtype_of($parent)); +} + +{ + my $type; + is( exception { $type = class_type 'MyExampleClass' }, undef, 'Make initial class_type' ); + coerce 'MyExampleClass', from 'Str', via { bless {}, 'MyExampleClass' }; + # We test class_type keeping the existing type (not making a new one) here. + is( exception { is(class_type('MyExampleClass'), $type, 're-running class_type gives same type') }, undef, 'No exception making duplicate class_type' );; + + # Next define a class which needs this type and it's original coercion + # Note this has to be after the 2nd class_type call to test the bug as M::M::Attribute grabs + # the type constraint which is there at the time the attribute decleration runs. + { + package HoldsExample; + use Moose; + + has foo => ( isa => 'MyExampleClass', is => 'ro', coerce => 1, required => 1 ); + no Moose; + } + + is( exception { isa_ok(HoldsExample->new(foo => "bar")->foo, 'MyExampleClass') }, undef, 'class_type coercion works' ); +} + +done_testing; diff --git a/t/type_constraints/coerced_parameterized_types.t b/t/type_constraints/coerced_parameterized_types.t new file mode 100644 index 0000000..10e3910 --- /dev/null +++ b/t/type_constraints/coerced_parameterized_types.t @@ -0,0 +1,55 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +BEGIN { + package MyList; + sub new { + my $class = shift; + bless { items => \@_ }, $class; + } + + sub items { + my $self = shift; + return @{ $self->{items} }; + } +} + +subtype 'MyList' => as 'Object' => where { $_->isa('MyList') }; + +is( exception { + coerce 'ArrayRef' + => from 'MyList' + => via { [ $_->items ] } +}, undef, '... created the coercion okay' ); + +my $mylist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MyList[Int]'); + +ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly (pass)'); +ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); +ok(!$mylist->check([10]), '... validated it correctly (fail)'); + +subtype 'EvenList' => as 'MyList' => where { $_->items % 2 == 0 }; + +# XXX: get this to work *without* the declaration. I suspect it'll be a new +# method in Moose::Meta::TypeCoercion that will look at the parents of the +# coerced type as well. but will that be too "action at a distance"-ey? +is( exception { + coerce 'ArrayRef' + => from 'EvenList' + => via { [ $_->items ] } +}, undef, '... created the coercion okay' ); + +my $evenlist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('EvenList[Int]'); + +ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly (fail)'); +ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly (pass)'); +ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); +ok(!$evenlist->check([10, 20]), '... validated it correctly (fail)'); + +done_testing; diff --git a/t/type_constraints/container_type_coercion.t b/t/type_constraints/container_type_coercion.t new file mode 100644 index 0000000..8ccb1bb --- /dev/null +++ b/t/type_constraints/container_type_coercion.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; + +# Array of Ints + +my $array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[Int]', + parent => find_type_constraint('ArrayRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); + +$r->add_type_constraint($array_of_ints); + +is(find_type_constraint('ArrayRef[Int]'), $array_of_ints, '... found the type we just added'); + +# Hash of Ints + +my $hash_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'HashRef[Int]', + parent => find_type_constraint('HashRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint'); + +$r->add_type_constraint($hash_of_ints); + +is(find_type_constraint('HashRef[Int]'), $hash_of_ints, '... found the type we just added'); + +## now attempt a coercion + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'ArrayRef[Int]' + => from 'HashRef[Int]' + => via { [ values %$_ ] }; + + has 'bar' => ( + is => 'ro', + isa => 'ArrayRef[Int]', + coerce => 1, + ); + +} + +my $foo = Foo->new(bar => { one => 1, two => 2, three => 3 }); +isa_ok($foo, 'Foo'); + +is_deeply([ sort @{$foo->bar} ], [ 1, 2, 3 ], '... our coercion worked!'); + +done_testing; diff --git a/t/type_constraints/container_type_constraint.t b/t/type_constraints/container_type_constraint.t new file mode 100644 index 0000000..a7120c5 --- /dev/null +++ b/t/type_constraints/container_type_constraint.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +# Array of Ints + +my $array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[Int]', + parent => find_type_constraint('ArrayRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); +ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); +ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); + +ok(!$array_of_ints->check(1), '... 1 failed successfully'); +ok(!$array_of_ints->check({}), '... {} failed successfully'); +ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Hash of Ints + +my $hash_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'HashRef[Int]', + parent => find_type_constraint('HashRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($hash_of_ints->check({ one => 1, two => 2, three => 3 }), '... { one => 1, two => 2, three => 3 } passed successfully'); +ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', 3 => 'three' }), '... { 1 => one, 2 => two, 3 => three } failed successfully'); +ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', three => 3 }), '... { 1 => one, 2 => two, three => 3 } failed successfully'); + +ok(!$hash_of_ints->check(1), '... 1 failed successfully'); +ok(!$hash_of_ints->check([]), '... [] failed successfully'); +ok(!$hash_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Array of Array of Ints + +my $array_of_array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[ArrayRef[Int]]', + parent => find_type_constraint('ArrayRef'), + type_parameter => $array_of_ints, +); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ 4, 5, 6 ]] +), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); +ok(!$array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ qw/foo bar/ ]] +), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); + +{ + my $anon_type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Foo]'); + isa_ok( $anon_type, 'Moose::Meta::TypeConstraint::Parameterized' ); + + my $param_type = $anon_type->type_parameter; + isa_ok( $param_type, 'Moose::Meta::TypeConstraint::Class' ); +} + +done_testing; diff --git a/t/type_constraints/custom_parameterized_types.t b/t/type_constraints/custom_parameterized_types.t new file mode 100644 index 0000000..ebe320c --- /dev/null +++ b/t/type_constraints/custom_parameterized_types.t @@ -0,0 +1,83 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +is( exception { + subtype 'AlphaKeyHash' => as 'HashRef' + => where { + # no keys match non-alpha + (grep { /[^a-zA-Z]/ } keys %$_) == 0 + }; +}, undef, '... created the subtype special okay' ); + +is( exception { + subtype 'Trihash' => as 'AlphaKeyHash' + => where { + keys(%$_) == 3 + }; +}, undef, '... created the subtype special okay' ); + +is( exception { + subtype 'Noncon' => as 'Item'; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('AlphaKeyHash'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'AlphaKeyHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); + + ok( $t->equals($t), "equals to self" ); + ok( !$t->equals($t->parent), "not equal to parent" ); +} + +my $hoi = Moose::Util::TypeConstraints::find_or_parse_type_constraint('AlphaKeyHash[Int]'); + +ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly'); +ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); +ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly'); +ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly'); + +ok( $hoi->equals($hoi), "equals to self" ); +ok( !$hoi->equals($hoi->parent), "equals to self" ); +ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" ); +ok( $hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); +ok( !$hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" ); + +my $th = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Trihash[Bool]'); + +ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly'); +ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly'); +ok(!$th->check({ one => 1, two => 2, three => 1 }), '... validated it correctly'); +ok(!$th->check({foo1 => 1, bar2 => 0, baz3 => 1}), '... validated it correctly'); + +isnt( exception { + Moose::Meta::TypeConstraint::Parameterized->new( + name => 'Str[Int]', + parent => find_type_constraint('Str'), + type_parameter => find_type_constraint('Int'), + ); +}, undef, 'non-containers cannot be parameterized' ); + +isnt( exception { + Moose::Meta::TypeConstraint::Parameterized->new( + name => 'Noncon[Int]', + parent => find_type_constraint('Noncon'), + type_parameter => find_type_constraint('Int'), + ); +}, undef, 'non-containers cannot be parameterized' ); + +done_testing; diff --git a/t/type_constraints/custom_type_errors.t b/t/type_constraints/custom_type_errors.t new file mode 100644 index 0000000..21cf981 --- /dev/null +++ b/t/type_constraints/custom_type_errors.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Animal; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Natural' => as 'Int' => where { $_ > 0 } => + message {"This number ($_) is not a positive integer!"}; + + subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } => + message {"This number ($_) is not less than ten!"}; + + has leg_count => ( + is => 'rw', + isa => 'NaturalLessThanTen', + lazy => 1, + default => 0, + ); +} + +is( exception { my $goat = Animal->new( leg_count => 4 ) }, undef, '... no errors thrown, value is good' ); +is( exception { my $spider = Animal->new( leg_count => 8 ) }, undef, '... no errors thrown, value is good' ); + +like( exception { my $fern = Animal->new( leg_count => 0 ) }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on new' ); + +like( exception { my $centipede = Animal->new( leg_count => 30 ) }, qr/This number \(30\) is not less than ten!/, 'gave custom subtype error message on new' ); + +my $chimera; +is( exception { $chimera = Animal->new( leg_count => 4 ) }, undef, '... no errors thrown, value is good' ); + +like( exception { $chimera->leg_count(0) }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on set to 0' ); + +like( exception { $chimera->leg_count(16) }, qr/This number \(16\) is not less than ten!/, 'gave custom subtype error message on set to 16' ); + +my $gimp = eval { Animal->new() }; +is( $@, '', '... no errors thrown, value is good' ); + +like( exception { $gimp->leg_count }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on lazy set to 0' ); + +done_testing; diff --git a/t/type_constraints/define_type_twice_throws.t b/t/type_constraints/define_type_twice_throws.t new file mode 100644 index 0000000..a9b9b83 --- /dev/null +++ b/t/type_constraints/define_type_twice_throws.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Some::Class; + use Moose::Util::TypeConstraints; + + subtype 'MySubType' => as 'Int' => where { 1 }; +} + +like( exception { + package Some::Other::Class; + use Moose::Util::TypeConstraints; + + subtype 'MySubType' => as 'Int' => where { 1 }; +}, qr/cannot be created again/, 'Trying to create same type twice throws' ); + +done_testing; diff --git a/t/type_constraints/duck_type_handles.t b/t/type_constraints/duck_type_handles.t new file mode 100644 index 0000000..d8dcf18 --- /dev/null +++ b/t/type_constraints/duck_type_handles.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; + +my @phonograph; +{ + package Duck; + use Moose; + + sub walk { + push @phonograph, 'footsteps', + } + + sub quack { + push @phonograph, 'quack'; + } + + package Swan; + use Moose; + + sub honk { + push @phonograph, 'honk'; + } + + package DucktypeTest; + use Moose; + use Moose::Util::TypeConstraints; + + my $ducktype = duck_type 'DuckType' => [qw(walk quack)]; + + has duck => ( + isa => $ducktype, + handles => $ducktype, + ); +} + +my $t = DucktypeTest->new(duck => Duck->new); +$t->quack; +is_deeply([splice @phonograph], ['quack']); + +$t->walk; +is_deeply([splice @phonograph], ['footsteps']); + +done_testing; diff --git a/t/type_constraints/duck_types.t b/t/type_constraints/duck_types.t new file mode 100644 index 0000000..d13d862 --- /dev/null +++ b/t/type_constraints/duck_types.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + + package Duck; + use Moose; + + sub quack { } + +} + +{ + + package Swan; + use Moose; + + sub honk { } + +} + +{ + + package RubberDuck; + use Moose; + + sub quack { } + +} + +{ + + package DucktypeTest; + use Moose; + use Moose::Util::TypeConstraints; + + duck_type 'DuckType' => [qw(quack)]; + duck_type 'SwanType' => [qw(honk)]; + + has duck => ( + isa => 'DuckType', + is => 'ro', + lazy_build => 1, + ); + + sub _build_duck { Duck->new } + + has swan => ( + isa => duck_type( [qw(honk)] ), + is => 'ro', + ); + + has other_swan => ( + isa => 'SwanType', + is => 'ro', + ); + +} + +# try giving it a duck +is( exception { DucktypeTest->new( duck => Duck->new ) }, undef, 'the Duck lives okay' ); + +# try giving it a swan which is like a duck, but not close enough +like( exception { DucktypeTest->new( duck => Swan->new ) }, qr/Swan is missing methods 'quack'/, "the Swan doesn't quack" ); + +# try giving it a rubber RubberDuckey +is( exception { DucktypeTest->new( swan => Swan->new ) }, undef, 'but a Swan can honk' ); + +# try giving it a rubber RubberDuckey +is( exception { DucktypeTest->new( duck => RubberDuck->new ) }, undef, 'the RubberDuck lives okay' ); + +# try with the other constraint form +is( exception { DucktypeTest->new( other_swan => Swan->new ) }, undef, 'but a Swan can honk' ); + +my $re = qr/Validation failed for 'DuckType' with value/; + +like( exception { DucktypeTest->new( duck => undef ) }, $re, 'Exception for undef' ); +like( exception { DucktypeTest->new( duck => [] ) }, $re, 'Exception for arrayref' ); +like( exception { DucktypeTest->new( duck => {} ) }, $re, 'Exception for hashref' ); +like( exception { DucktypeTest->new( duck => \'foo' ) }, $re, 'Exception for scalar ref' ); + +done_testing; diff --git a/t/type_constraints/enum.t b/t/type_constraints/enum.t new file mode 100644 index 0000000..74fd064 --- /dev/null +++ b/t/type_constraints/enum.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util (); + +use Moose::Util::TypeConstraints; + +enum Letter => ['a'..'z', 'A'..'Z']; +enum Language => ['Perl 5', 'Perl 6', 'PASM', 'PIR']; # any others? ;) +enum Metacharacter => ['*', '+', '?', '.', '|', '(', ')', '[', ']', '\\']; + +my @valid_letters = ('a'..'z', 'A'..'Z'); + +my @invalid_letters = qw/ab abc abcd/; +push @invalid_letters, qw/0 4 9 ~ @ $ %/; +push @invalid_letters, qw/l33t st3v4n 3num/; + +my @valid_languages = ('Perl 5', 'Perl 6', 'PASM', 'PIR'); +my @invalid_languages = ('perl 5', 'Python', 'Ruby', 'Perl 666', 'PASM++'); +# note that "perl 5" is invalid because case now matters + +my @valid_metacharacters = (qw/* + ? . | ( ) [ ] /, '\\'); +my @invalid_metacharacters = qw/< > & % $ @ ! ~ `/; +push @invalid_metacharacters, qw/.* fish(sticks)? atreides/; +push @invalid_metacharacters, '^1?$|^(11+?)\1+$'; + +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(Letter($_), "'$_' is a letter") for @valid_letters; +ok(!Letter($_), "'$_' is not a letter") for @invalid_letters; + +ok(Language($_), "'$_' is a language") for @valid_languages; +ok(!Language($_), "'$_' is not a language") for @invalid_languages; + +ok(Metacharacter($_), "'$_' is a metacharacter") for @valid_metacharacters; +ok(!Metacharacter($_), "'$_' is not a metacharacter") + for @invalid_metacharacters; + +# check anon enums + +my $anon_enum = enum \@valid_languages; +isa_ok($anon_enum, 'Moose::Meta::TypeConstraint'); + +is($anon_enum->name, '__ANON__', '... got the right name'); +is($anon_enum->parent->name, 'Str', '... got the right parent name'); + +ok($anon_enum->check($_), "'$_' is a language") for @valid_languages; + + +ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" ); +ok( $anon_enum->equals( $anon_enum ), "equals itself" ); +ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" ); + +ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object'); +ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object'); + +ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type'); +ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type'); + +# validation +like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'ZeroValues', values => []) }, qr/You must have at least one value to enumerate through/ ); + +is( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'OneValue', values => [ 'a' ]) }, undef); + +like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'ReferenceInEnum', values => [ 'a', {} ]) }, qr/Enum values must be strings, not 'HASH\(0x\w+\)'/ ); + +like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'UndefInEnum', values => [ 'a', undef ]) }, qr/Enum values must be strings, not undef/ ); + +like( exception { + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has error => ( + is => 'ro', + isa => enum ['a', 'aa', 'aaa'], # should be parenthesized! + default => 'aa', + ); +}, qr/enum called with an array reference and additional arguments\. Did you mean to parenthesize the enum call's parameters\?/ ); + + +done_testing; diff --git a/t/type_constraints/inlining.t b/t/type_constraints/inlining.t new file mode 100644 index 0000000..b14ae75 --- /dev/null +++ b/t/type_constraints/inlining.t @@ -0,0 +1,197 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +use List::Util 1.33 (); +use Moose::Util::TypeConstraints; + +#<<< +subtype 'Inlinable', + as 'Str', + where { $_ !~ /Q/ }, + inline_as { "defined $_[1] && ! ref $_[1] && $_[1] !~ /Q/" }; + +subtype 'NotInlinable', + as 'Str', + where { $_ !~ /Q/ }; +#>>> + +my $inlinable = find_type_constraint('Inlinable'); +my $not_inlinable = find_type_constraint('NotInlinable'); + +{ + ok( + $inlinable->can_be_inlined, + 'Inlinable returns true for can_be_inlined' + ); + + is( + $inlinable->_inline_check('$foo'), + '( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )', + 'got expected inline code for Inlinable constraint' + ); + + ok( + !$not_inlinable->can_be_inlined, + 'NotInlinable returns false for can_be_inlined' + ); + + like( + exception { $not_inlinable->_inline_check('$foo') }, + qr/Cannot inline a type constraint check for NotInlinable/, + 'threw an exception when asking for inlinable code from type which cannot be inlined' + ); +} + +{ + my $aofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayRef[Inlinable]'); + + ok( + $aofi->can_be_inlined, + 'ArrayRef[Inlinable] returns true for can_be_inlined' + ); + + is( + $aofi->_inline_check('$foo'), + q{( do { do {my $check = $foo;ref($check) eq "ARRAY" && &List::Util::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } )}, + 'got expected inline code for ArrayRef[Inlinable] constraint' + ); + + my $aofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayRef[NotInlinable]'); + + ok( + !$aofni->can_be_inlined, + 'ArrayRef[NotInlinable] returns false for can_be_inlined' + ); +} + +subtype 'ArrayOfInlinable', + as 'ArrayRef[Inlinable]'; + +subtype 'ArrayOfNotInlinable', + as 'ArrayRef[NotInlinable]'; +{ + my $aofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayOfInlinable'); + + ok( + $aofi->can_be_inlined, + 'ArrayOfInlinable returns true for can_be_inlined' + ); + + is( + $aofi->_inline_check('$foo'), + q{( do { do {my $check = $foo;ref($check) eq "ARRAY" && &List::Util::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } )}, + 'got expected inline code for ArrayOfInlinable constraint' + ); + + my $aofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayOfNotInlinable'); + + ok( + !$aofni->can_be_inlined, + 'ArrayOfNotInlinable returns false for can_be_inlined' + ); +} + +{ + my $hoaofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'HashRef[ArrayRef[Inlinable]]'); + + ok( + $hoaofi->can_be_inlined, + 'HashRef[ArrayRef[Inlinable]] returns true for can_be_inlined' + ); + + is( + $hoaofi->_inline_check('$foo'), + q{( do { do {my $check = $foo;ref($check) eq "HASH" && &List::Util::all(sub { ( do { do {my $check = $_;ref($check) eq "ARRAY" && &List::Util::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } ) }, values %{$check})} } )}, + 'got expected inline code for HashRef[ArrayRef[Inlinable]] constraint' + ); + + my $hoaofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'HashRef[ArrayRef[NotInlinable]]'); + + ok( + !$hoaofni->can_be_inlined, + 'HashRef[ArrayRef[NotInlinable]] returns false for can_be_inlined' + ); +} + +{ + my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Inlinable | Object'); + + ok( + $iunion->can_be_inlined, + 'Inlinable | Object returns true for can_be_inlined' + ); + + is( + $iunion->_inline_check('$foo'), + '((( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )) || (( do { Scalar::Util::blessed($foo) } )))', + 'got expected inline code for Inlinable | Object constraint' + ); + + my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'NotInlinable | Object'); + + ok( + !$niunion->can_be_inlined, + 'NotInlinable | Object returns false for can_be_inlined' + ); +} + +{ + my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | Inlinable'); + + ok( + $iunion->can_be_inlined, + 'Object | Inlinable returns true for can_be_inlined' + ); + + is( + $iunion->_inline_check('$foo'), + '((( do { Scalar::Util::blessed($foo) } )) || (( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )))', + 'got expected inline code for Object | Inlinable constraint' + ); + + my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | NotInlinable'); + + ok( + !$niunion->can_be_inlined, + 'Object | NotInlinable returns false for can_be_inlined' + ); +} + +{ + my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | Inlinable | CodeRef'); + + ok( + $iunion->can_be_inlined, + 'Object | Inlinable | CodeRef returns true for can_be_inlined' + ); + + is( + $iunion->_inline_check('$foo'), + q{((( do { Scalar::Util::blessed($foo) } )) || (( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )) || (( do { ref($foo) eq "CODE" } )))}, + 'got expected inline code for Object | Inlinable | CodeRef constraint' + ); + + my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | NotInlinable | CodeRef'); + + ok( + !$niunion->can_be_inlined, + 'Object | NotInlinable | CodeRef returns false for can_be_inlined' + ); +} + +done_testing; diff --git a/t/type_constraints/match_type_operator.t b/t/type_constraints/match_type_operator.t new file mode 100644 index 0000000..016646a --- /dev/null +++ b/t/type_constraints/match_type_operator.t @@ -0,0 +1,227 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +# some simple type dispatching ... + +subtype 'Null' + => as 'ArrayRef' + => where { scalar @{$_} == 0 }; + +sub head { + match_on_type @_ => + Null => sub { die "Cannot get the head of Null" }, + ArrayRef => sub { $_->[0] }; +} + +sub tail { + match_on_type @_ => + Null => sub { die "Cannot get the tail of Null" }, + ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] }; +} + +sub len { + match_on_type @_ => + Null => sub { 0 }, + ArrayRef => sub { len( tail( $_ ) ) + 1 }; +} + +sub rev { + match_on_type @_ => + Null => sub { [] }, + ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] }; +} + +is( len( [] ), 0, '... got the right length'); +is( len( [ 1 ] ), 1, '... got the right length'); +is( len( [ 1 .. 5 ] ), 5, '... got the right length'); +is( len( [ 1 .. 50 ] ), 50, '... got the right length'); + +is_deeply( + rev( [ 1 .. 5 ] ), + [ reverse 1 .. 5 ], + '... got the right reversed value' +); + +# break down a Maybe Type ... + +sub break_it_down { + match_on_type shift, + 'Maybe[Str]' => sub { + match_on_type $_ => + 'Undef' => sub { 'undef' }, + 'Str' => sub { $_ } + }, + sub { 'default' } +} + + +is( break_it_down( 'FOO' ), 'FOO', '... got the right value'); +is( break_it_down( [] ), 'default', '... got the right value'); +is( break_it_down( undef ), 'undef', '... got the right value'); +is( break_it_down(), 'undef', '... got the right value'); + +# checking against enum types + +enum RGB => [qw[ red green blue ]]; +enum CMYK => [qw[ cyan magenta yellow black ]]; + +sub is_acceptable_color { + match_on_type shift, + 'RGB' => sub { 'RGB' }, + 'CMYK' => sub { 'CMYK' }, + sub { die "bad color $_" }; +} + +is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'green' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'red' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value'); + +isnt( exception { + is_acceptable_color( 'orange' ) +}, undef, '... got the exception' ); + +## using it in an OO context + +{ + package LinkedList; + use Moose; + use Moose::Util::TypeConstraints; + + has 'next' => ( + is => 'ro', + isa => __PACKAGE__, + lazy => 1, + default => sub { __PACKAGE__->new }, + predicate => 'has_next' + ); + + sub pprint { + my $list = shift; + match_on_type $list => + subtype( + as 'LinkedList', + where { ! $_->has_next } + ) => sub { '[]' }, + 'LinkedList' => sub { '[' . $_->next->pprint . ']' }; + } +} + +my $l = LinkedList->new; +is($l->pprint, '[]', '... got the right pprint'); +$l->next; +is($l->pprint, '[[]]', '... got the right pprint'); +$l->next->next; +is($l->pprint, '[[[]]]', '... got the right pprint'); +$l->next->next->next; +is($l->pprint, '[[[[]]]]', '... got the right pprint'); + +# basic data dumper + +{ + package Foo; + use Moose; + + sub to_string { 'Foo()' } +} + +use B; + +sub ppprint { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + $_ . ' => ' . ppprint( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' }, + CodeRef => sub { 'sub { ... }' }, + RegexpRef => sub { 'qr/' . $_ . '/' }, + GlobRef => sub { '*' . B::svref_2object($_)->NAME }, + Object => sub { $_->can('to_string') ? $_->to_string : $_ }, + ScalarRef => sub { '\\' . ppprint( ${$_} ) }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'undef' }, + => sub { die "I don't know what $_ is" }; +} + +# The stringification of qr// has changed in 5.13.5+ +my $re_prefix = qr/x/ =~ /\(\?\^/ ? '(?^:' :'(?-xism:'; + +is( + ppprint( + { + one => [ 1, 2, "three", 4, "five", \(my $x = "six") ], + two => undef, + three => sub { "OH HAI" }, + four => qr/.*?/, + five => \*ppprint, + six => Foo->new, + } + ), + qq~{ five => *ppprint, four => qr/$re_prefix.*?)/, one => [ 1, 2, "three", 4, "five", \\"six" ], six => Foo(), three => sub { ... }, two => undef }~, + '... got the right pretty printed values' +); + +# simple JSON serializer + +sub to_json { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + '"' . $_ . '" : ' . to_json( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'null' }, + => sub { die "$_ is not acceptable json type" }; +} + +is( + to_json( { one => 1, two => 2 } ), + '{ "one" : 1, "two" : 2 }', + '... got our valid JSON' +); + +is( + to_json( { + one => [ 1, 2, 3, 4 ], + two => undef, + three => "Hello World" + } ), + '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }', + '... got our valid JSON' +); + + +# some error cases + +sub not_enough_matches { + my $x = shift; + match_on_type $x => + Undef => sub { 'hello undef world' }, + CodeRef => sub { $_->('Hello code ref world') }; +} + +like( exception { + not_enough_matches( [] ) +}, qr/No cases matched for /, '... not enough matches' ); + +done_testing; diff --git a/t/type_constraints/maybe_type_constraint.t b/t/type_constraints/maybe_type_constraint.t new file mode 100644 index 0000000..3bbdba2 --- /dev/null +++ b/t/type_constraints/maybe_type_constraint.t @@ -0,0 +1,129 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +my $type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]'); +isa_ok($type, 'Moose::Meta::TypeConstraint'); +isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized'); + +ok( $type->equals($type), "equals self" ); +ok( !$type->equals($type->parent), "not equal to parent" ); +ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" ); +ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" ); +ok( $type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); +ok( !$type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" ); +ok( !$type->equals( Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" ); + +ok($type->check(10), '... checked type correctly (pass)'); +ok($type->check(undef), '... checked type correctly (pass)'); +ok(!$type->check('Hello World'), '... checked type correctly (fail)'); +ok(!$type->check([]), '... checked type correctly (fail)'); + +{ + package Bar; + use Moose; + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1); + has 'bar' => (is => 'rw', isa => class_type('Bar')); + has 'maybe_bar' => (is => 'rw', isa => maybe_type(class_type('Bar'))); +} + +is( exception { + Foo->new(arr => [], bar => Bar->new); +}, undef, '... Bar->new isa Bar' ); + +isnt( exception { + Foo->new(arr => [], bar => undef); +}, undef, '... undef isnta Bar' ); + +is( exception { + Foo->new(arr => [], maybe_bar => Bar->new); +}, undef, '... Bar->new isa maybe(Bar)' ); + +is( exception { + Foo->new(arr => [], maybe_bar => undef); +}, undef, '... undef isa maybe(Bar)' ); + +isnt( exception { + Foo->new(arr => [], maybe_bar => 1); +}, undef, '... 1 isnta maybe(Bar)' ); + +is( exception { + Foo->new(arr => []); +}, undef, '... it worked!' ); + +is( exception { + Foo->new(arr => undef); +}, undef, '... it worked!' ); + +isnt( exception { + Foo->new(arr => 100); +}, undef, '... failed the type check' ); + +isnt( exception { + Foo->new(arr => 'hello world'); +}, undef, '... failed the type check' ); + + +{ + package Test::MooseX::Types::Maybe; + use Moose; + + has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]'); + has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]'); + has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]'); + has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]'); + has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]'); +} + +ok my $obj = Test::MooseX::Types::Maybe->new + => 'Create good test object'; + +## Maybe[Int] + +ok my $Maybe_Int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]') + => 'made TC Maybe[Int]'; + +ok $Maybe_Int->check(1) + => 'passed (1)'; + +ok $obj->Maybe_Int(1) + => 'assigned (1)'; + +ok $Maybe_Int->check() + => 'passed ()'; + +ok $obj->Maybe_Int() + => 'assigned ()'; + +ok $Maybe_Int->check(0) + => 'passed (0)'; + +ok defined $obj->Maybe_Int(0) + => 'assigned (0)'; + +ok $Maybe_Int->check(undef) + => 'passed (undef)'; + +ok sub {$obj->Maybe_Int(undef); 1}->() + => 'assigned (undef)'; + +ok !$Maybe_Int->check("") + => 'failed ("")'; + +like( exception { $obj->Maybe_Int("") }, qr/Attribute \(Maybe_Int\) does not pass the type constraint/, 'failed assigned ("")' ); + +ok !$Maybe_Int->check("a") + => 'failed ("a")'; + +like( exception { $obj->Maybe_Int("a") }, qr/Attribute \(Maybe_Int\) does not pass the type constraint/, 'failed assigned ("a")' ); + +done_testing; diff --git a/t/type_constraints/misc_type_tests.t b/t/type_constraints/misc_type_tests.t new file mode 100644 index 0000000..e2413ab --- /dev/null +++ b/t/type_constraints/misc_type_tests.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util qw(refaddr); + +use Moose::Util::TypeConstraints; + +# subtype 'aliasing' ... + +is( exception { + subtype 'Numb3rs' => as 'Num'; +}, undef, '... create bare subtype fine' ); + +my $numb3rs = find_type_constraint('Numb3rs'); +isa_ok($numb3rs, 'Moose::Meta::TypeConstraint'); + +# subtype with unions + +{ + package Test::Moose::Meta::TypeConstraint::Union; + + use overload '""' => sub {'Broken|Test'}, fallback => 1; + use Moose; + + extends 'Moose::Meta::TypeConstraint'; +} + +my $dummy_instance = Test::Moose::Meta::TypeConstraint::Union->new; + +ok $dummy_instance => "Created Instance"; + +isa_ok $dummy_instance, + 'Test::Moose::Meta::TypeConstraint::Union' => 'isa correct type'; + +is "$dummy_instance", "Broken|Test" => + 'Got expected stringification result'; + +my $subtype1 = subtype 'New1' => as $dummy_instance; + +ok $subtype1 => 'made a subtype from our type object'; + +my $subtype2 = subtype 'New2' => as $subtype1; + +ok $subtype2 => 'made a subtype of our subtype'; + +# assert_valid + +{ + my $type = find_type_constraint('Num'); + + my $ok_1 = eval { $type->assert_valid(1); }; + ok($ok_1, "we can assert_valid that 1 is of type $type"); + + my $ok_2 = eval { $type->assert_valid('foo'); }; + my $error = $@; + ok(! $ok_2, "'foo' is not of type $type"); + like( + $error, + qr{validation failed for .\Q$type\E.}i, + "correct error thrown" + ); +} + +{ + for my $t (qw(Bar Foo)) { + my $tc = Moose::Meta::TypeConstraint->new({ + name => $t, + }); + + Moose::Util::TypeConstraints::register_type_constraint($tc); + } + + my $foo = Moose::Util::TypeConstraints::find_type_constraint('Foo'); + my $bar = Moose::Util::TypeConstraints::find_type_constraint('Bar'); + + ok(!$foo->equals($bar), "Foo type is not equal to Bar type"); + ok( $foo->equals($foo), "Foo equals Foo"); + ok( 0+$foo == refaddr($foo), "overloading works"); +} + +ok $subtype1, "type constraint boolean overload works"; + +done_testing; diff --git a/t/type_constraints/name_conflicts.t b/t/type_constraints/name_conflicts.t new file mode 100644 index 0000000..1b52b5e --- /dev/null +++ b/t/type_constraints/name_conflicts.t @@ -0,0 +1,112 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Types; + use Moose::Util::TypeConstraints; + + type 'Foo1'; + subtype 'Foo2', as 'Str'; + class_type 'Foo3'; + role_type 'Foo4'; + + { package Foo5; use Moose; } + { package Foo6; use Moose::Role; } + { package IsaAttr; use Moose; has foo => (is => 'ro', isa => 'Foo7'); } + { package DoesAttr; use Moose; has foo => (is => 'ro', does => 'Foo8'); } +} + +{ + my $anon = 0; + my @checks = ( + [1, sub { type $_[0] }, 'type'], + [1, sub { subtype $_[0], as 'Str' }, 'subtype'], + [1, sub { class_type $_[0] }, 'class_type'], + [1, sub { role_type $_[0] }, 'role_type'], + # should these two die? + [0, sub { eval "package $_[0]; use Moose; 1" || die $@ }, 'use Moose'], + [0, sub { eval "package $_[0]; use Moose::Role; 1" || die $@ }, 'use Moose::Role'], + [0, sub { + $anon++; + eval <<CLASS || die $@; + package Anon$anon; + use Moose; + has foo => (is => 'ro', isa => '$_[0]'); + 1 +CLASS + }, 'isa => "Thing"'], + [0, sub { + $anon++; + eval <<CLASS || die $@; + package Anon$anon; + use Moose; + has foo => (is => 'ro', does => '$_[0]'); + 1 +CLASS + }, 'does => "Thing"'], + ); + + sub check_conflicts { + my ($type_name) = @_; + my $type = find_type_constraint($type_name); + for my $check (@checks) { + my ($should_fail, $code, $desc) = @$check; + + $should_fail = 0 + if overriding_with_equivalent_type($type, $desc); + unload_class($type_name); + + if ($should_fail) { + like( + exception { $code->($type_name) }, + qr/^The type constraint '$type_name' has already been created in [\w:]+ and cannot be created again in [\w:]+/, + "trying to override $type_name via '$desc' should die" + ); + } + else { + is( + exception { $code->($type_name) }, + undef, + "trying to override $type_name via '$desc' should do nothing" + ); + } + is($type, find_type_constraint($type_name), "type didn't change"); + } + } + + sub unload_class { + my ($class) = @_; + my $meta = Class::MOP::class_of($class); + return unless $meta; + $meta->add_package_symbol('@ISA', []); + $meta->remove_package_symbol('&'.$_) + for $meta->list_all_package_symbols('CODE'); + undef $meta; + Class::MOP::remove_metaclass_by_name($class); + } + + sub overriding_with_equivalent_type { + my ($type, $desc) = @_; + if ($type->isa('Moose::Meta::TypeConstraint::Class')) { + return 1 if $desc eq 'use Moose' + || $desc eq 'class_type' + || $desc eq 'isa => "Thing"'; + } + if ($type->isa('Moose::Meta::TypeConstraint::Role')) { + return 1 if $desc eq 'use Moose::Role' + || $desc eq 'role_type' + || $desc eq 'does => "Thing"'; + } + return; + } +} + +{ + check_conflicts($_) for map { "Foo$_" } 1..8; +} + +done_testing; diff --git a/t/type_constraints/normalize_type_name.t b/t/type_constraints/normalize_type_name.t new file mode 100644 index 0000000..406f59c --- /dev/null +++ b/t/type_constraints/normalize_type_name.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +## First, we check that the new regex parsing works + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Str]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Str ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Str ]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ Str]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ Str ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ Str ]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int] ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int] ]') + ], + [ "ArrayRef", "HashRef[Int]" ] => + 'Correctly parsed ArrayRef[ HashRef[Int] ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int ] ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int ] ]') + ], + [ "ArrayRef", "HashRef[Int ]" ] => + 'Correctly parsed ArrayRef[ HashRef[Int ] ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Int|Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Int|Str]') + ], + [ "ArrayRef", "Int|Str" ] => 'Correctly parsed ArrayRef[Int|Str]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ArrayRef[Int]|Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ArrayRef[Int]|Str]') + ], + [ "ArrayRef", "ArrayRef[Int]|Str" ] => + 'Correctly parsed ArrayRef[ArrayRef[Int]|Str]'; + +## creating names via subtype + +ok my $r = Moose::Util::TypeConstraints->get_type_constraint_registry => + 'Got registry object'; + +ok my $subtype_a1 + = subtype( 'subtype_a1' => as 'HashRef[Int]' ), => 'created subtype_a1'; + +ok my $subtype_a2 + = subtype( 'subtype_a2' => as 'HashRef[ Int]' ), => 'created subtype_a2'; + +ok my $subtype_a3 + = subtype( 'subtype_a2' => as 'HashRef[Int ]' ), => 'created subtype_a2'; + +ok my $subtype_a4 = subtype( 'subtype_a2' => as 'HashRef[ Int ]' ), => + 'created subtype_a2'; + +is $subtype_a1->parent->name, $subtype_a2->parent->name => 'names match'; + +is $subtype_a1->parent->name, $subtype_a3->parent->name => 'names match'; + +is $subtype_a1->parent->name, $subtype_a4->parent->name => 'names match'; + +ok my $subtype_b1 = subtype( 'subtype_b1' => as 'HashRef[Int|Str]' ), => + 'created subtype_b1'; + +ok my $subtype_b2 = subtype( 'subtype_b2' => as 'HashRef[Int | Str]' ), => + 'created subtype_b2'; + +ok my $subtype_b3 = subtype( 'subtype_b3' => as 'HashRef[Str|Int]' ), => + 'created subtype_b3'; + +is $subtype_b1->parent->name, $subtype_b2->parent->name => 'names match'; + +is $subtype_b1->parent->name, $subtype_b3->parent->name => 'names match'; + +is $subtype_b2->parent->name, $subtype_b3->parent->name => 'names match'; + +## testing via add_constraint + +ok my $union1 = Moose::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union1'; + +ok my $union2 = Moose::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[ Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union2'; + +ok my $union3 = Moose::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[Int |Str ] | ArrayRef[Int | HashRef ]') => 'Created Union3'; + +is $union1->name, $union2->name, 'names match'; + +is $union1->name, $union3->name, 'names match'; + +is $union2->name, $union3->name, 'names match'; + +done_testing; diff --git a/t/type_constraints/parameterize_from.t b/t/type_constraints/parameterize_from.t new file mode 100644 index 0000000..8c2485c --- /dev/null +++ b/t/type_constraints/parameterize_from.t @@ -0,0 +1,74 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +# testing the parameterize method + +{ + my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef'; + + my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]'; + + my $int = Moose::Util::TypeConstraints::find_type_constraint('Int'); + + my $from_parameterizable = $parameterizable->parameterize($int); + + isa_ok $parameterizable, + 'Moose::Meta::TypeConstraint::Parameterizable', => + 'Got expected type instance'; + + package Test::Moose::Meta::TypeConstraint::Parameterizable; + use Moose; + + has parameterizable => ( is => 'rw', isa => $parameterizable ); + has parameterized => ( is => 'rw', isa => $parameterized ); + has from_parameterizable => ( is => 'rw', isa => $from_parameterizable ); +} + +# Create and check a dummy object + +ok my $params = Test::Moose::Meta::TypeConstraint::Parameterizable->new() => + 'Create Dummy object for testing'; + +isa_ok $params, 'Test::Moose::Meta::TypeConstraint::Parameterizable' => + 'isa correct type'; + +# test parameterizable + +is( exception { + $params->parameterizable( { a => 'Hello', b => 'World' } ); +}, undef, 'No problem setting parameterizable' ); + +is_deeply $params->parameterizable, + { a => 'Hello', b => 'World' } => 'Got expected values'; + +# test parameterized + +is( exception { + $params->parameterized( { a => 1, b => 2 } ); +}, undef, 'No problem setting parameterized' ); + +is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values'; + +like( exception { + $params->parameterized( { a => 'Hello', b => 'World' } ); + }, qr/Attribute \(parameterized\) does not pass the type constraint/, 'parameterized throws expected error' ); + +# test from_parameterizable + +is( exception { + $params->from_parameterizable( { a => 1, b => 2 } ); +}, undef, 'No problem setting from_parameterizable' ); + +is_deeply $params->from_parameterizable, + { a => 1, b => 2 } => 'Got expected values'; + +like( exception { + $params->from_parameterizable( { a => 'Hello', b => 'World' } ); + }, qr/Attribute \(from_parameterizable\) does not pass the type constraint/, 'from_parameterizable throws expected error' ); + +done_testing; diff --git a/t/type_constraints/role_type_constraint.t b/t/type_constraints/role_type_constraint.t new file mode 100644 index 0000000..3da8204 --- /dev/null +++ b/t/type_constraints/role_type_constraint.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Gorch; + use Moose::Role; + + package Bar; + use Moose::Role; + + package Foo; + use Moose::Role; + + with qw(Bar Gorch); + + package FooC; + use Moose; + with qw(Foo); + + package BarC; + use Moose; + with qw(Bar); + +} + +is( exception { role_type('Boop', message { "${_} is not a Boop" }) }, undef, 'role_type keywork works with message' ); + +my $type = find_type_constraint("Foo"); + +is( $type->role, "Foo", "role attribute" ); + +ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); + +ok( $type->is_subtype_of("Bar"), "subtype of bar" ); + +ok( $type->is_subtype_of("Object"), "subtype of Object" ); + +ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of unknown type name" ); +ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of unknown type name" ); + +ok( find_type_constraint("Bar")->check(FooC->new), "Foo passes Bar" ); +ok( find_type_constraint("Bar")->check(BarC->new), "Bar passes Bar" ); +ok( !find_type_constraint("Gorch")->check(BarC->new), "but Bar doesn't pass Gorch"); + +my $boop = find_type_constraint("Boop"); +ok( $boop->has_message, 'Boop has a message'); +my $error = $boop->get_message(FooC->new); +like( $error, qr/is not a Boop/, 'boop gives correct error message'); + + +ok( $type->equals($type), "equals self" ); +ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" ); +ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" ); +ok( !$type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" ); +ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" ); + +{ # See block comment in t/type_constraints/class_type_constraint.t + my $type; + is( exception { $type = role_type 'MyExampleRole' }, undef, 'Make initial role_type' ); + is( exception { is(role_type('MyExampleRole'), $type, 're-running role_type gives same type') }, undef, 'No exception making duplicate role_type' );; + is( exception { ok( ! $type->is_subtype_of('Bar'), 'MyExampleRole is not a subtype of Bar' ) }, undef, 'No exception for is_subtype_of undefined role' ); +} + +done_testing; diff --git a/t/type_constraints/subtype_auto_vivify_parent.t b/t/type_constraints/subtype_auto_vivify_parent.t new file mode 100644 index 0000000..e5cd2e9 --- /dev/null +++ b/t/type_constraints/subtype_auto_vivify_parent.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + + +{ + package Foo; + + sub new { + my $class = shift; + + return bless {@_}, $class; + } +} + +subtype 'FooWithSize' + => as 'Foo' + => where { $_[0]->{size} }; + + +my $type = find_type_constraint('FooWithSize'); +ok( $type, 'made a FooWithSize constraint' ); +ok( $type->parent, 'type has a parent type' ); +is( $type->parent->name, 'Foo', 'parent type is Foo' ); +isa_ok( $type->parent, 'Moose::Meta::TypeConstraint::Class', + 'parent type constraint is a class type' ); + +done_testing; diff --git a/t/type_constraints/subtyping_parameterized_types.t b/t/type_constraints/subtyping_parameterized_types.t new file mode 100644 index 0000000..faee937 --- /dev/null +++ b/t/type_constraints/subtyping_parameterized_types.t @@ -0,0 +1,127 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +is( exception { + subtype 'MySpecialHash' => as 'HashRef[Int]'; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MySpecialHash'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated {one=>1, two=>2} correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); + + ok( $t->equals($t), "equals to self" ); + ok( !$t->equals( $t->parent ), "not equal to parent" ); + ok( $t->parent->equals( $t->parent ), "parent equals to self" ); + + ok( !$t->is_a_type_of("ThisTypeDoesNotExist"), "not a non existant type" ); + ok( !$t->is_subtype_of("ThisTypeDoesNotExist"), "not a subtype of a non existant type" ); +} + +is( exception { + subtype 'MySpecialHashExtended' + => as 'HashRef[Int]' + => where { + # all values are less then 10 + (scalar grep { $_ < 10 } values %{$_}) ? 1 : undef + }; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MySpecialHashExtended'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHashExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated { zero => 10, one => 11, two => 12 } correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); +} + +is( exception { + subtype 'MyNonSpecialHash' + => as "HashRef" + => where { keys %$_ == 3 }; +}, undef ); + +{ + my $t = find_type_constraint('MyNonSpecialHash'); + + isa_ok($t, 'Moose::Meta::TypeConstraint'); + isa_ok($t, 'Moose::Meta::TypeConstraint::Parameterizable'); + + ok( $t->check({ one => 1, two => "foo", three => [] }), "validated" ); + ok( !$t->check({ one => 1 }), "failed" ); +} + +{ + my $t = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MyNonSpecialHash[Int]'); + + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + ok( $t->check({ one => 1, two => 2, three => 3 }), "validated" ); + ok( !$t->check({ one => 1, two => "foo", three => [] }), "failed" ); + ok( !$t->check({ one => 1 }), "failed" ); +} + +{ + ## Because to throw errors in M:M:Parameterizable needs Moose loaded in + ## order to throw errors. In theory the use Moose belongs to that class + ## but when I put it there causes all sorts or trouble. In theory this is + ## never a real problem since you are likely to use Moose somewhere when you + ## are creating type constraints. + use Moose (); + + my $MyArrayRefInt = subtype 'MyArrayRefInt', + as 'ArrayRef[Int]'; + + my $BiggerInt = subtype 'BiggerInt', + as 'Int', + where {$_>10}; + + my $SubOfMyArrayRef = subtype 'SubOfMyArrayRef', + as 'MyArrayRefInt[BiggerInt]'; + + ok $MyArrayRefInt->check([1,2,3]), '[1,2,3] is okay'; + ok ! $MyArrayRefInt->check(["a","b"]), '["a","b"] is not'; + ok $BiggerInt->check(100), '100 is big enough'; + ok ! $BiggerInt->check(5), '5 is big enough'; + ok $SubOfMyArrayRef->check([15,20,25]), '[15,20,25] is a bunch of big ints'; + ok ! $SubOfMyArrayRef->check([15,5,25]), '[15,5,25] is NOT a bunch of big ints'; + + like( exception { + my $SubOfMyArrayRef = subtype 'SubSubOfMyArrayRef', + as 'SubOfMyArrayRef[Str]'; + }, qr/Str is not a subtype of BiggerInt/, 'Failed to parameterize with a bad type parameter' ); +} + +{ + my $RefToInt = subtype as 'ScalarRef[Int]'; + + ok $RefToInt->check(\1), '\1 is okay'; + ok !$RefToInt->check(1), '1 is not'; + ok !$RefToInt->check(\"foo"), '\"foo" is not'; +} + +done_testing; diff --git a/t/type_constraints/subtyping_union_types.t b/t/type_constraints/subtyping_union_types.t new file mode 100644 index 0000000..d2a514f --- /dev/null +++ b/t/type_constraints/subtyping_union_types.t @@ -0,0 +1,108 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +is( exception { + subtype 'MyCollections' => as 'ArrayRef | HashRef'; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MyCollections'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MyCollections', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); + + ok($t->check([]), '... validated it correctly'); + ok($t->check({}), '... validated it correctly'); + ok(!$t->check(1), '... validated it correctly'); +} + +is( exception { + subtype 'MyCollectionsExtended' + => as 'ArrayRef|HashRef' + => where { + if (ref($_) eq 'ARRAY') { + return if scalar(@$_) < 2; + } + elsif (ref($_) eq 'HASH') { + return if scalar(keys(%$_)) < 2; + } + 1; + }; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MyCollectionsExtended'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MyCollectionsExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); + + ok(!$t->check([]), '... validated it correctly'); + ok($t->check([1, 2]), '... validated it correctly'); + + ok(!$t->check({}), '... validated it correctly'); + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + + ok(!$t->check(1), '... validated it correctly'); +} + +{ + my $union = Moose::Util::TypeConstraints::find_or_create_type_constraint('Int|ArrayRef[Int]'); + subtype 'UnionSub', as 'Int|ArrayRef[Int]'; + + my $subtype = find_type_constraint('UnionSub'); + + ok( + !$union->is_a_type_of('Ref'), + 'Int|ArrayRef[Int] is not a type of Ref' + ); + ok( + !$subtype->is_a_type_of('Ref'), + 'subtype of Int|ArrayRef[Int] is not a type of Ref' + ); + + ok( + $union->is_a_type_of('Defined'), + 'Int|ArrayRef[Int] is a type of Defined' + ); + ok( + $subtype->is_a_type_of('Defined'), + 'subtype of Int|ArrayRef[Int] is a type of Defined' + ); + + ok( + !$union->is_subtype_of('Ref'), + 'Int|ArrayRef[Int] is not a subtype of Ref' + ); + ok( + !$subtype->is_subtype_of('Ref'), + 'subtype of Int|ArrayRef[Int] is not a subtype of Ref' + ); + + ok( + $union->is_subtype_of('Defined'), + 'Int|ArrayRef[Int] is a subtype of Defined' + ); + ok( + $subtype->is_subtype_of('Defined'), + 'subtype of Int|ArrayRef[Int] is a subtype of Defined' + ); +} + +done_testing; diff --git a/t/type_constraints/throw_error.t b/t/type_constraints/throw_error.t new file mode 100644 index 0000000..662d327 --- /dev/null +++ b/t/type_constraints/throw_error.t @@ -0,0 +1,14 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + + +eval { Moose::Util::TypeConstraints::create_type_constraint_union() }; + +like( $@, qr/\QYou must pass in at least 2 type names to make a union/, + 'can throw a proper error without Moose being loaded by the caller' ); + +done_testing; diff --git a/t/type_constraints/type_coersion_on_lazy_attributes.t b/t/type_constraints/type_coersion_on_lazy_attributes.t new file mode 100644 index 0000000..c8943fe --- /dev/null +++ b/t/type_constraints/type_coersion_on_lazy_attributes.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; + +{ + package SomeClass; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'DigitSix' => as 'Num' + => where { /^6$/ }; + subtype 'TextSix' => as 'Str' + => where { /Six/i }; + coerce 'TextSix' + => from 'DigitSix' + => via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' }; + + has foo => ( + is => 'ro', + isa => 'TextSix', + coerce => 1, + default => 6, + lazy => 1 + ); +} + +my $attr = SomeClass->meta->get_attribute('foo'); +is($attr->get_value(SomeClass->new()), 'Six'); +is(SomeClass->new()->foo, 'Six'); + +done_testing; diff --git a/t/type_constraints/type_names.t b/t/type_constraints/type_names.t new file mode 100644 index 0000000..bc4dcaf --- /dev/null +++ b/t/type_constraints/type_names.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::TypeConstraint; +use Moose::Util::TypeConstraints; + + +TODO: +{ + local $TODO = 'type names are not validated in the TC metaclass'; + + # Test written in this way to avoid a warning from like(undef, qr...); + # -- rjbs, 2010-10-25 + my $error = exception { + Moose::Meta::TypeConstraint->new( name => 'Foo-Bar' ) + }; + + if (defined $error) { + like( + $error, + qr/contains invalid characters/, + 'Type names cannot contain a dash', + ); + } else { + fail("Type names cannot contain a dash"); + } +} + +is( exception { Moose::Meta::TypeConstraint->new( name => 'Foo.Bar::Baz' ) }, undef, 'Type names can contain periods and colons' ); + +like( exception { subtype 'Foo-Baz' => as 'Item' }, qr/contains invalid characters/, 'Type names cannot contain a dash (via subtype sugar)' ); + +is( exception { subtype 'Foo.Bar::Baz' => as 'Item' }, undef, 'Type names can contain periods and colons (via subtype sugar)' ); + +is( Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[In-valid]'), + undef, + 'find_or_parse_type_constraint returns undef on an invalid name' ); + +is( Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Va.lid]'), + 'ArrayRef[Va.lid]', + 'find_or_parse_type_constraint returns name for valid name' ); + +done_testing; diff --git a/t/type_constraints/type_notation_parser.t b/t/type_constraints/type_notation_parser.t new file mode 100644 index 0000000..66720a4 --- /dev/null +++ b/t/type_constraints/type_notation_parser.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +=pod + +This is a good candidate for LectroTest +Volunteers welcome :) + +=cut + +## check the containers + +ok(Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_), + '... this correctly detected a container (' . $_ . ')') + for ( + 'ArrayRef[Foo]', + 'ArrayRef[Foo | Int]', + 'ArrayRef[ArrayRef[Int]]', + 'ArrayRef[ArrayRef[Int | Foo]]', + 'ArrayRef[ArrayRef[Int|Str]]', +); + +ok(!Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_), + '... this correctly detected a non-container (' . $_ . ')') + for ( + 'ArrayRef[]', + 'ArrayRef[Foo]Bar', +); + +{ + my %split_tests = ( + 'ArrayRef[Foo]' => [ 'ArrayRef', 'Foo' ], + 'ArrayRef[Foo | Int]' => [ 'ArrayRef', 'Foo | Int' ], + 'ArrayRef[Foo|Int]' => [ 'ArrayRef', 'Foo|Int' ], + # these will get processed with recusion, + # so we only need to detect it once + 'ArrayRef[ArrayRef[Int]]' => [ 'ArrayRef', 'ArrayRef[Int]' ], + 'ArrayRef[ArrayRef[Int | Foo]]' => [ 'ArrayRef', 'ArrayRef[Int | Foo]' ], + 'ArrayRef[ArrayRef[Int|Str]]' => [ 'ArrayRef', 'ArrayRef[Int|Str]' ], + ); + + is_deeply( + [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint($_) ], + $split_tests{$_}, + '... this correctly split the container (' . $_ . ')' + ) for keys %split_tests; +} + +## now for the unions + +ok(Moose::Util::TypeConstraints::_detect_type_constraint_union($_), + '... this correctly detected union (' . $_ . ')') + for ( + 'Int | Str', + 'Int|Str', + 'ArrayRef[Foo] | Int', + 'ArrayRef[Foo]|Int', + 'Int | ArrayRef[Foo]', + 'Int|ArrayRef[Foo]', + 'ArrayRef[Foo | Int] | Str', + 'ArrayRef[Foo|Int]|Str', + 'Str | ArrayRef[Foo | Int]', + 'Str|ArrayRef[Foo|Int]', + 'Some|Silly|Name|With|Pipes | Int', + 'Some|Silly|Name|With|Pipes|Int', +); + +ok(!Moose::Util::TypeConstraints::_detect_type_constraint_union($_), + '... this correctly detected a non-union (' . $_ . ')') + for ( + 'Int', + 'ArrayRef[Foo | Int]', + 'ArrayRef[Foo|Int]', +); + +{ + my %split_tests = ( + 'Int | Str' => [ 'Int', 'Str' ], + 'Int|Str' => [ 'Int', 'Str' ], + 'ArrayRef[Foo] | Int' => [ 'ArrayRef[Foo]', 'Int' ], + 'ArrayRef[Foo]|Int' => [ 'ArrayRef[Foo]', 'Int' ], + 'Int | ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], + 'Int|ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], + 'ArrayRef[Foo | Int] | Str' => [ 'ArrayRef[Foo | Int]', 'Str' ], + 'ArrayRef[Foo|Int]|Str' => [ 'ArrayRef[Foo|Int]', 'Str' ], + 'Str | ArrayRef[Foo | Int]' => [ 'Str', 'ArrayRef[Foo | Int]' ], + 'Str|ArrayRef[Foo|Int]' => [ 'Str', 'ArrayRef[Foo|Int]' ], + 'Some|Silly|Name|With|Pipes | Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], + 'Some|Silly|Name|With|Pipes|Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], + ); + + is_deeply( + [ Moose::Util::TypeConstraints::_parse_type_constraint_union($_) ], + $split_tests{$_}, + '... this correctly split the union (' . $_ . ')' + ) for keys %split_tests; +} + +done_testing; diff --git a/t/type_constraints/types_and_undef.t b/t/type_constraints/types_and_undef.t new file mode 100644 index 0000000..5fdff67 --- /dev/null +++ b/t/type_constraints/types_and_undef.t @@ -0,0 +1,108 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + use Scalar::Util (); + + type Number + => where { defined($_) && !ref($_) && Scalar::Util::looks_like_number($_) }; + + type String + => where { defined($_) && !ref($_) && !Scalar::Util::looks_like_number($_) }; + + has vUndef => ( is => 'rw', isa => 'Undef' ); + has vDefined => ( is => 'rw', isa => 'Defined' ); + has vInt => ( is => 'rw', isa => 'Int' ); + has vNumber => ( is => 'rw', isa => 'Number' ); + has vStr => ( is => 'rw', isa => 'Str' ); + has vString => ( is => 'rw', isa => 'String' ); + + has v_lazy_Undef => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Undef' ); + has v_lazy_Defined => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Defined' ); + has v_lazy_Int => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Int' ); + has v_lazy_Number => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Number' ); + has v_lazy_Str => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Str' ); + has v_lazy_String => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'String' ); +} + +# EXPORT TYPE CONSTRAINTS +# +Moose::Util::TypeConstraints->export_type_constraints_as_functions; + +ok( Undef(undef), '... undef is a Undef'); +ok(!Defined(undef), '... undef is NOT a Defined'); +ok(!Int(undef), '... undef is NOT an Int'); +ok(!Number(undef), '... undef is NOT a Number'); +ok(!Str(undef), '... undef is NOT a Str'); +ok(!String(undef), '... undef is NOT a String'); + +ok(!Undef(5), '... 5 is a NOT a Undef'); +ok(Defined(5), '... 5 is a Defined'); +ok(Int(5), '... 5 is an Int'); +ok(Number(5), '... 5 is a Number'); +ok(Str(5), '... 5 is a Str'); +ok(!String(5), '... 5 is NOT a String'); + +ok(!Undef(0.5), '... 0.5 is a NOT a Undef'); +ok(Defined(0.5), '... 0.5 is a Defined'); +ok(!Int(0.5), '... 0.5 is NOT an Int'); +ok(Number(0.5), '... 0.5 is a Number'); +ok(Str(0.5), '... 0.5 is a Str'); +ok(!String(0.5), '... 0.5 is NOT a String'); + +ok(!Undef('Foo'), '... "Foo" is NOT a Undef'); +ok(Defined('Foo'), '... "Foo" is a Defined'); +ok(!Int('Foo'), '... "Foo" is NOT an Int'); +ok(!Number('Foo'), '... "Foo" is NOT a Number'); +ok(Str('Foo'), '... "Foo" is a Str'); +ok(String('Foo'), '... "Foo" is a String'); + + +my $foo = Foo->new; + +is( exception { $foo->vUndef(undef) }, undef, '... undef is a Foo->Undef' ); +isnt( exception { $foo->vDefined(undef) }, undef, '... undef is NOT a Foo->Defined' ); +isnt( exception { $foo->vInt(undef) }, undef, '... undef is NOT a Foo->Int' ); +isnt( exception { $foo->vNumber(undef) }, undef, '... undef is NOT a Foo->Number' ); +isnt( exception { $foo->vStr(undef) }, undef, '... undef is NOT a Foo->Str' ); +isnt( exception { $foo->vString(undef) }, undef, '... undef is NOT a Foo->String' ); + +isnt( exception { $foo->vUndef(5) }, undef, '... 5 is NOT a Foo->Undef' ); +is( exception { $foo->vDefined(5) }, undef, '... 5 is a Foo->Defined' ); +is( exception { $foo->vInt(5) }, undef, '... 5 is a Foo->Int' ); +is( exception { $foo->vNumber(5) }, undef, '... 5 is a Foo->Number' ); +is( exception { $foo->vStr(5) }, undef, '... 5 is a Foo->Str' ); +isnt( exception { $foo->vString(5) }, undef, '... 5 is NOT a Foo->String' ); + +isnt( exception { $foo->vUndef(0.5) }, undef, '... 0.5 is NOT a Foo->Undef' ); +is( exception { $foo->vDefined(0.5) }, undef, '... 0.5 is a Foo->Defined' ); +isnt( exception { $foo->vInt(0.5) }, undef, '... 0.5 is NOT a Foo->Int' ); +is( exception { $foo->vNumber(0.5) }, undef, '... 0.5 is a Foo->Number' ); +is( exception { $foo->vStr(0.5) }, undef, '... 0.5 is a Foo->Str' ); +isnt( exception { $foo->vString(0.5) }, undef, '... 0.5 is NOT a Foo->String' ); + +isnt( exception { $foo->vUndef('Foo') }, undef, '... "Foo" is NOT a Foo->Undef' ); +is( exception { $foo->vDefined('Foo') }, undef, '... "Foo" is a Foo->Defined' ); +isnt( exception { $foo->vInt('Foo') }, undef, '... "Foo" is NOT a Foo->Int' ); +isnt( exception { $foo->vNumber('Foo') }, undef, '... "Foo" is NOT a Foo->Number' ); +is( exception { $foo->vStr('Foo') }, undef, '... "Foo" is a Foo->Str' ); +is( exception { $foo->vString('Foo') }, undef, '... "Foo" is a Foo->String' ); + +# the lazy tests + +is( exception { $foo->v_lazy_Undef() }, undef, '... undef is a Foo->Undef' ); +isnt( exception { $foo->v_lazy_Defined() }, undef, '... undef is NOT a Foo->Defined' ); +isnt( exception { $foo->v_lazy_Int() }, undef, '... undef is NOT a Foo->Int' ); +isnt( exception { $foo->v_lazy_Number() }, undef, '... undef is NOT a Foo->Number' ); +isnt( exception { $foo->v_lazy_Str() }, undef, '... undef is NOT a Foo->Str' ); +isnt( exception { $foo->v_lazy_String() }, undef, '... undef is NOT a Foo->String' ); + +done_testing; diff --git a/t/type_constraints/union_is_a_type_of.t b/t/type_constraints/union_is_a_type_of.t new file mode 100644 index 0000000..60b6ef7 --- /dev/null +++ b/t/type_constraints/union_is_a_type_of.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +use Moose::Util::TypeConstraints 'find_type_constraint'; + +use Moose::Meta::TypeConstraint::Union; + +my ( $item, $int, $classname, $num ) + = map { find_type_constraint($_) } qw{Item Int ClassName Num}; + +ok( $int->is_subtype_of($item), 'Int is subtype of Item' ); +ok( $classname->is_subtype_of($item), 'ClassName is subtype of Item' ); +ok( + ( not $int->is_subtype_of($classname) ), + 'Int is not subtype of ClassName' +); +ok( + ( not $classname->is_subtype_of($int) ), + 'ClassName is not subtype of Int' +); + +my $union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $int, $classname ] ); + +my @domain_values = qw( 85439 Moose::Meta::TypeConstraint ); +is( + exception { $union->assert_valid($_) }, + undef, + qq{Union accepts "$_".} +) for @domain_values; + +ok( + $union->is_subtype_of( find_type_constraint($_) ), + "Int|ClassName is a subtype of $_" +) for qw{Item Defined Value Str}; + +ok( + ( not $union->is_subtype_of( find_type_constraint($_) ) ), + "Int|ClassName is not a subtype of $_" +) for qw{Num Int ClassName}; + +ok( + ( not $union->is_a_type_of( find_type_constraint($_) ) ), + "Int|ClassName is not a type of $_" +) for qw{Int ClassName}; +done_testing; diff --git a/t/type_constraints/union_types.t b/t/type_constraints/union_types.t new file mode 100644 index 0000000..276492c --- /dev/null +++ b/t/type_constraints/union_types.t @@ -0,0 +1,195 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +my $Str = find_type_constraint('Str'); +isa_ok( $Str, 'Moose::Meta::TypeConstraint' ); + +my $Undef = find_type_constraint('Undef'); +isa_ok( $Undef, 'Moose::Meta::TypeConstraint' ); + +ok( !$Str->check(undef), '... Str cannot accept an Undef value' ); +ok( $Str->check('String'), '... Str can accept an String value' ); +ok( !$Undef->check('String'), '... Undef cannot accept an Str value' ); +ok( $Undef->check(undef), '... Undef can accept an Undef value' ); + +my $Str_or_Undef = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str, $Undef ] ); +isa_ok( $Str_or_Undef, 'Moose::Meta::TypeConstraint::Union' ); + +ok( + $Str_or_Undef->check(undef), + '... (Str | Undef) can accept an Undef value' +); +ok( + $Str_or_Undef->check('String'), + '... (Str | Undef) can accept a String value' +); + +ok( !$Str_or_Undef->is_a_type_of($Str), "not a subtype of Str" ); +ok( !$Str_or_Undef->is_a_type_of($Undef), "not a subtype of Undef" ); + +cmp_ok( + $Str_or_Undef->find_type_for('String'), 'eq', 'Str', + 'find_type_for Str' +); +cmp_ok( + $Str_or_Undef->find_type_for(undef), 'eq', 'Undef', + 'find_type_for Undef' +); +ok( + !defined( $Str_or_Undef->find_type_for( sub { } ) ), + 'no find_type_for CodeRef' +); + +ok( !$Str_or_Undef->equals($Str), "not equal to Str" ); +ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" ); +ok( + $Str_or_Undef->equals( + Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str, $Undef ] + ) + ), + "equal to clone" +); +ok( + $Str_or_Undef->equals( + Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Undef, $Str ] + ) + ), + "equal to reversed clone" +); + +ok( + !$Str_or_Undef->is_a_type_of("ThisTypeDoesNotExist"), + "not type of non existent type" +); +ok( + !$Str_or_Undef->is_subtype_of("ThisTypeDoesNotExist"), + "not subtype of non existent type" +); + +is( + $Str_or_Undef->parent, + find_type_constraint('Item'), + 'parent of Str|Undef is Item' +); + +is_deeply( + [$Str_or_Undef->parents], + [find_type_constraint('Item')], + 'parents of Str|Undef is Item' +); + +# another .... + +my $ArrayRef = find_type_constraint('ArrayRef'); +isa_ok( $ArrayRef, 'Moose::Meta::TypeConstraint' ); + +my $HashRef = find_type_constraint('HashRef'); +isa_ok( $HashRef, 'Moose::Meta::TypeConstraint' ); + +ok( $ArrayRef->check( [] ), '... ArrayRef can accept an [] value' ); +ok( !$ArrayRef->check( {} ), '... ArrayRef cannot accept an {} value' ); +ok( $HashRef->check( {} ), '... HashRef can accept an {} value' ); +ok( !$HashRef->check( [] ), '... HashRef cannot accept an [] value' ); + +my $ArrayRef_or_HashRef = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $ArrayRef, $HashRef ] ); +isa_ok( $ArrayRef_or_HashRef, 'Moose::Meta::TypeConstraint::Union' ); + +ok( $ArrayRef_or_HashRef->check( [] ), + '... (ArrayRef | HashRef) can accept []' ); +ok( $ArrayRef_or_HashRef->check( {} ), + '... (ArrayRef | HashRef) can accept {}' ); + +ok( + !$ArrayRef_or_HashRef->check( \( my $var1 ) ), + '... (ArrayRef | HashRef) cannot accept scalar refs' +); +ok( + !$ArrayRef_or_HashRef->check( sub { } ), + '... (ArrayRef | HashRef) cannot accept code refs' +); +ok( + !$ArrayRef_or_HashRef->check(50), + '... (ArrayRef | HashRef) cannot accept Numbers' +); + +diag $ArrayRef_or_HashRef->validate( [] ); + +ok( + !defined( $ArrayRef_or_HashRef->validate( [] ) ), + '... (ArrayRef | HashRef) can accept []' +); +ok( + !defined( $ArrayRef_or_HashRef->validate( {} ) ), + '... (ArrayRef | HashRef) can accept {}' +); + +like( + $ArrayRef_or_HashRef->validate( \( my $var2 ) ), + qr/Validation failed for \'ArrayRef\' with value .+ and Validation failed for \'HashRef\' with value .+ in \(ArrayRef\|HashRef\)/, + '... (ArrayRef | HashRef) cannot accept scalar refs' +); + +like( + $ArrayRef_or_HashRef->validate( sub { } ), + qr/Validation failed for \'ArrayRef\' with value .+ and Validation failed for \'HashRef\' with value .+ in \(ArrayRef\|HashRef\)/, + '... (ArrayRef | HashRef) cannot accept code refs' +); + +is( + $ArrayRef_or_HashRef->validate(50), + 'Validation failed for \'ArrayRef\' with value 50 and Validation failed for \'HashRef\' with value 50 in (ArrayRef|HashRef)', + '... (ArrayRef | HashRef) cannot accept Numbers' +); + +is( + $ArrayRef_or_HashRef->parent, + find_type_constraint('Ref'), + 'parent of ArrayRef|HashRef is Ref' +); + +my $double_union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str_or_Undef, $ArrayRef_or_HashRef ] ); + +is( + $double_union->parent, + find_type_constraint('Item'), + 'parent of (Str|Undef)|(ArrayRef|HashRef) is Item' +); + +ok( + $double_union->is_subtype_of('Item'), + '(Str|Undef)|(ArrayRef|HashRef) is a subtype of Item' +); + +ok( + $double_union->is_a_type_of('Item'), + '(Str|Undef)|(ArrayRef|HashRef) is a type of Item' +); + +ok( + !$double_union->is_a_type_of('Str'), + '(Str|Undef)|(ArrayRef|HashRef) is not a type of Str' +); + +type 'SomeType', where { 1 }; +type 'OtherType', where { 1 }; + +my $parentless_union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ + find_type_constraint('SomeType'), + find_type_constraint('OtherType'), + ], +); + +is($parentless_union->parent, undef, "no common ancestor gives undef parent"); + + +done_testing; diff --git a/t/type_constraints/union_types_and_coercions.t b/t/type_constraints/union_types_and_coercions.t new file mode 100644 index 0000000..8c3f807 --- /dev/null +++ b/t/type_constraints/union_types_and_coercions.t @@ -0,0 +1,181 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Requires qw(IO::String IO::File); # skip all if not installed + +{ + package Email::Moose; + use Moose; + use Moose::Util::TypeConstraints; + + use IO::String; + + our $VERSION = '0.01'; + + # create subtype for IO::String + + subtype 'IO::String' + => as 'Object' + => where { $_->isa('IO::String') }; + + coerce 'IO::String' + => from 'Str' + => via { IO::String->new($_) }, + => from 'ScalarRef', + => via { IO::String->new($_) }; + + # create subtype for IO::File + + subtype 'IO::File' + => as 'Object' + => where { $_->isa('IO::File') }; + + coerce 'IO::File' + => from 'FileHandle' + => via { bless $_, 'IO::File' }; + + # create the alias + + subtype 'IO::StringOrFile' => as 'IO::String | IO::File'; + + # attributes + + has 'raw_body' => ( + is => 'rw', + isa => 'IO::StringOrFile', + coerce => 1, + default => sub { IO::String->new() }, + ); + + sub as_string { + my ($self) = @_; + my $fh = $self->raw_body(); + return do { local $/; <$fh> }; + } +} + +{ + my $email = Email::Moose->new; + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, undef, '... got correct empty string'); +} + +{ + my $email = Email::Moose->new(raw_body => '... this is my body ...'); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, '... this is my body ...', '... got correct string'); + + is( exception { + $email->raw_body('... this is the next body ...'); + }, undef, '... this will coerce correctly' ); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, '... this is the next body ...', '... got correct string'); +} + +{ + my $str = '... this is my body (ref) ...'; + + my $email = Email::Moose->new(raw_body => \$str); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, $str, '... got correct string'); + + my $str2 = '... this is the next body (ref) ...'; + + is( exception { + $email->raw_body(\$str2); + }, undef, '... this will coerce correctly' ); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, $str2, '... got correct string'); +} + +{ + my $io_str = IO::String->new('... this is my body (IO::String) ...'); + + my $email = Email::Moose->new(raw_body => $io_str); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + is($email->raw_body, $io_str, '... and it is the one we expected'); + + is($email->as_string, '... this is my body (IO::String) ...', '... got correct string'); + + my $io_str2 = IO::String->new('... this is the next body (IO::String) ...'); + + is( exception { + $email->raw_body($io_str2); + }, undef, '... this will coerce correctly' ); + + isa_ok($email->raw_body, 'IO::String'); + is($email->raw_body, $io_str2, '... and it is the one we expected'); + + is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string'); +} + +{ + my $fh; + + open($fh, '<', $0) || die "Could not open $0"; + + my $email = Email::Moose->new(raw_body => $fh); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::File'); + + close($fh); +} + +{ + my $fh = IO::File->new($0); + + my $email = Email::Moose->new(raw_body => $fh); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::File'); + is($email->raw_body, $fh, '... and it is the one we expected'); +} + +{ + package Foo; + + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Coerced' => as 'ArrayRef'; + coerce 'Coerced' + => from 'Value' + => via { [ $_ ] }; + + has carray => ( + is => 'ro', + isa => 'Coerced | Coerced', + coerce => 1, + ); +} + +{ + my $foo; + is( exception { $foo = Foo->new( carray => 1 ) }, undef, 'Can pass non-ref value for carray' ); + is_deeply( + $foo->carray, [1], + 'carray was coerced to an array ref' + ); + + like( exception { Foo->new( carray => {} ) }, qr/\QValidation failed for 'Coerced|Coerced' with value \E(?!undef)/, 'Cannot pass a hash ref for carray attribute, and hash ref is not coerced to an undef' ); +} + +done_testing; diff --git a/t/type_constraints/util_find_type_constraint.t b/t/type_constraints/util_find_type_constraint.t new file mode 100644 index 0000000..8da3af0 --- /dev/null +++ b/t/type_constraints/util_find_type_constraint.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +foreach my $type_name (qw( + Any + Item + Bool + Undef + Defined + Value + Num + Int + Str + Ref + ScalarRef + ArrayRef + HashRef + CodeRef + RegexpRef + Object + )) { + is(find_type_constraint($type_name)->name, + $type_name, + '... got the right name for ' . $type_name); +} + +# TODO: +# add tests for is_subtype_of which confirm the hierarchy + +done_testing; diff --git a/t/type_constraints/util_more_type_coercion.t b/t/type_constraints/util_more_type_coercion.t new file mode 100644 index 0000000..0aa7f66 --- /dev/null +++ b/t/type_constraints/util_more_type_coercion.t @@ -0,0 +1,130 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package HTTPHeader; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'HTTPHeader' + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) }; + + coerce 'HTTPHeader' + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); + + package Engine; + use strict; + use warnings; + use Moose; + + has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); +} + +{ + my $engine = Engine->new(); + isa_ok($engine, 'Engine'); + + # try with arrays + + is( exception { + $engine->header([ 1, 2, 3 ]); + }, undef, '... type was coerced without incident' ); + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); + + # try with hash + + is( exception { + $engine->header({ one => 1, two => 2, three => 3 }); + }, undef, '... type was coerced without incident' ); + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); + + isnt( exception { + $engine->header("Foo"); + }, undef, '... dies with the wrong type, even after coercion' ); + + is( exception { + $engine->header(HTTPHeader->new); + }, undef, '... lives with the right type, even after coercion' ); +} + +{ + my $engine = Engine->new(header => [ 1, 2, 3 ]); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); +} + +{ + my $engine = Engine->new(header => { one => 1, two => 2, three => 3 }); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); +} + +{ + my $engine = Engine->new(header => HTTPHeader->new()); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + ok(!defined($engine->header->hash), '... no hash value set'); + ok(!defined($engine->header->array), '... no array value set'); +} + +isnt( exception { + Engine->new(header => 'Foo'); +}, undef, '... dies correctly with bad params' ); + +isnt( exception { + Engine->new(header => \(my $var)); +}, undef, '... dies correctly with bad params' ); + +{ + my $tc = Moose::Util::TypeConstraints::find_type_constraint('HTTPHeader'); + isa_ok($tc, 'Moose::Meta::TypeConstraint', 'HTTPHeader TC'); + + my $from_aref = $tc->assert_coerce([ 1, 2, 3 ]); + isa_ok($from_aref, 'HTTPHeader', 'assert_coerce from aref to HTTPHeader'); + is_deeply($from_aref->array, [ 1, 2, 3 ], '...and has the right guts'); + + my $from_href = $tc->assert_coerce({ a => 1 }); + isa_ok($from_href, 'HTTPHeader', 'assert_coerce from href to HTTPHeader'); + is_deeply($from_href->hash, { a => 1 }, '...and has the right guts'); + + like( exception { $tc->assert_coerce('total garbage') }, qr/Validation failed for .HTTPHeader./, "assert_coerce throws if result is not acceptable" ); +} + +done_testing; diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t new file mode 100644 index 0000000..534b190 --- /dev/null +++ b/t/type_constraints/util_std_type_constraints.t @@ -0,0 +1,1305 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +use Eval::Closure; +use IO::File; +use Moose::Util::TypeConstraints; +use Scalar::Util qw( blessed openhandle ); + +my $ZERO = 0; +my $ONE = 1; +my $INT = 100; +my $NEG_INT = -100; +my $NUM = 42.42; +my $NEG_NUM = -42.42; + +my $EMPTY_STRING = q{}; +my $STRING = 'foo'; +my $NUM_IN_STRING = 'has 42 in it'; +my $INT_WITH_NL1 = "1\n"; +my $INT_WITH_NL2 = "\n1"; + +my $SCALAR_REF = \( my $var ); +my $SCALAR_REF_REF = \$SCALAR_REF; +my $ARRAY_REF = []; +my $HASH_REF = {}; +my $CODE_REF = sub { }; + +my $GLOB = do { no warnings 'once'; *GLOB_REF }; +my $GLOB_REF = \$GLOB; + +open my $FH, '<', $0 or die "Could not open $0 for the test"; + +my $FH_OBJECT = IO::File->new( $0, 'r' ) + or die "Could not open $0 for the test"; + +my $REGEX = qr/../; +my $REGEX_OBJ = bless qr/../, 'BlessedQR'; +my $FAKE_REGEX = bless {}, 'Regexp'; + +my $OBJECT = bless {}, 'Foo'; + +my $UNDEF = undef; + +{ + package Thing; + + sub foo { } +} + +my $CLASS_NAME = 'Thing'; + +{ + package Role; + use Moose::Role; + + sub foo { } +} + +my $ROLE_NAME = 'Role'; + +my %tests = ( + Any => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Item => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Defined => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $UNDEF, + ], + }, + Undef => { + accept => [ + $UNDEF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + }, + Bool => { + accept => [ + $ZERO, + $ONE, + $EMPTY_STRING, + $UNDEF, + ], + reject => [ + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + }, + Maybe => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Value => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $GLOB, + ], + reject => [ + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Ref => { + accept => [ + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $GLOB, + $UNDEF, + ], + }, + Num => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + ], + reject => [ + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + $INT_WITH_NL1, + $INT_WITH_NL2, + ], + }, + Int => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Str => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + ], + reject => [ + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + ScalarRef => { + accept => [ + $SCALAR_REF, + $SCALAR_REF_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + ArrayRef => { + accept => [ + $ARRAY_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + HashRef => { + accept => [ + $HASH_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + CodeRef => { + accept => [ + $CODE_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + RegexpRef => { + accept => [ + $REGEX, + $REGEX_OBJ, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $OBJECT, + $UNDEF, + $FAKE_REGEX, + ], + }, + GlobRef => { + accept => [ + $GLOB_REF, + $FH, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $FH_OBJECT, + $OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $UNDEF, + ], + }, + FileHandle => { + accept => [ + $FH, + $FH_OBJECT, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $UNDEF, + ], + }, + Object => { + accept => [ + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + }, + ClassName => { + accept => [ + $CLASS_NAME, + $ROLE_NAME, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + RoleName => { + accept => [ + $ROLE_NAME, + ], + reject => [ + $CLASS_NAME, + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, +); + +for my $name ( sort keys %tests ) { + test_constraint( $name, $tests{$name} ); + + test_constraint( + Moose::Util::TypeConstraints::find_or_create_type_constraint( + "$name|$name"), + $tests{$name} + ); +} + +my %substr_test_str = ( + ClassName => 'x' . $CLASS_NAME, + RoleName => 'x' . $ROLE_NAME, +); + +# We need to test that the Str constraint (and types that derive from it) +# accept the return val of substr() - which means passing that return val +# directly to the checking code +foreach my $type_name (qw(Str Num Int ClassName RoleName)) +{ + my $str = $substr_test_str{$type_name} || '123456789'; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name); + + my $unoptimized + = $type->has_parent + ? $type->_compile_subtype( $type->constraint ) + : $type->_compile_type( $type->constraint ); + + my $inlined; + { + $inlined = eval_closure( + source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', + ); + } + + ok( + $type->check( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using ->check' + ); + ok( + $unoptimized->( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using unoptimized constraint' + ); + ok( + $inlined->( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using inlined constraint' + ); + + # only Str accepts empty strings. + next unless $type_name eq 'Str'; + + ok( + $type->check( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using ->check' + ); + ok( + $unoptimized->( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using unoptimized constraint' + ); + ok( + $inlined->( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using inlined constraint' + ); +} + +{ + my $class_tc = class_type('Thing'); + + test_constraint( + $class_tc, { + accept => [ + ( bless {}, 'Thing' ), + ], + reject => [ + 'Thing', + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + } + ); +} + +{ + package Duck; + + sub quack { } + sub flap { } +} + +{ + package DuckLike; + + sub quack { } + sub flap { } +} + +{ + package Bird; + + sub flap { } +} + +{ + my @methods = qw( quack flap ); + duck_type 'Duck' => \@methods; + + test_constraint( + 'Duck', { + accept => [ + ( bless {}, 'Duck' ), + ( bless {}, 'DuckLike' ), + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ( bless {}, 'Bird' ), + $UNDEF, + ], + } + ); +} + +{ + my @allowed = qw( bar baz quux ); + enum 'Enumerated' => \@allowed; + + test_constraint( + 'Enumerated', { + accept => \@allowed, + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + } + ); +} + +{ + my $union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ + find_type_constraint('Int'), + find_type_constraint('Object'), + ], + ); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} +{ + note 'Anonymous Union Test'; + + my $union = union(['Int','Object']); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} +{ + note 'Named Union Test'; + union 'NamedUnion' => ['Int','Object']; + + test_constraint( + 'NamedUnion', { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} + +{ + note 'Combined Union Test'; + my $union = union( [ 'Int', enum( [qw[ red green blue ]] ) ] ); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + 'red', + 'green', + 'blue', + ], + reject => [ + 'yellow', + 'pink', + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} + + +{ + enum 'Enum1' => ['a', 'b']; + enum 'Enum2' => ['x', 'y']; + + subtype 'EnumUnion', as 'Enum1 | Enum2'; + + test_constraint( + 'EnumUnion', { + accept => [qw( a b x y )], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + } + ); +} + +{ + package DoesRole; + + use Moose; + + with 'Role'; +} + +# Test how $_ is used in XS implementation +{ + local $_ = qr/./; + ok( + Moose::Util::TypeConstraints::Builtins::_RegexpRef(), + '$_ is RegexpRef' + ); + ok( + !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1), + '$_ is not read when param provided' + ); + + $_ = bless qr/./, 'Blessed'; + + ok( + Moose::Util::TypeConstraints::Builtins::_RegexpRef(), + '$_ is RegexpRef' + ); + + $_ = 42; + ok( + !Moose::Util::TypeConstraints::Builtins::_RegexpRef(), + '$_ is not RegexpRef' + ); + ok( + Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./), + '$_ is not read when param provided' + ); +} + +close $FH + or warn "Could not close the filehandle $0 for test"; +$FH_OBJECT->close + or warn "Could not close the filehandle $0 for test"; + +done_testing; + +sub test_constraint { + my $type = shift; + my $tests = shift; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + unless ( blessed $type ) { + $type = Moose::Util::TypeConstraints::find_type_constraint($type) + or BAIL_OUT("No such type $type!"); + } + + my $name = $type->name; + + my $unoptimized + = $type->has_parent + ? $type->_compile_subtype( $type->constraint ) + : $type->_compile_type( $type->constraint ); + + my $inlined; + if ( $type->can_be_inlined ) { + $inlined = eval_closure( + source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', + environment => $type->inline_environment, + ); + } + + my $class = Moose::Meta::Class->create_anon( + superclasses => ['Moose::Object'], + ); + $class->add_attribute( + simple => ( + is => 'ro', + isa => $type, + ) + ); + + $class->add_attribute( + collection => ( + traits => ['Array'], + isa => 'ArrayRef[' . $type->name . ']', + default => sub { [] }, + handles => { add_to_collection => 'push' }, + ) + ); + + my $anon_class = $class->name; + + for my $accept ( @{ $tests->{accept} || [] } ) { + my $described = describe($accept); + ok( + $type->check($accept), + "$name accepts $described using ->check" + ); + ok( + $unoptimized->($accept), + "$name accepts $described using unoptimized constraint" + ); + if ($inlined) { + ok( + $inlined->($accept), + "$name accepts $described using inlined constraint" + ); + } + + is( + exception { + $anon_class->new( simple => $accept ); + }, + undef, + "no exception passing $described to constructor with $name" + ); + + is( + exception { + $anon_class->new()->add_to_collection($accept); + }, + undef, + "no exception passing $described to native trait push method with $name" + ); + } + + for my $reject ( @{ $tests->{reject} || [] } ) { + my $described = describe($reject); + ok( + !$type->check($reject), + "$name rejects $described using ->check" + ); + ok( + !$unoptimized->($reject), + "$name rejects $described using unoptimized constraint" + ); + if ($inlined) { + ok( + !$inlined->($reject), + "$name rejects $described using inlined constraint" + ); + } + + ok( + exception { + $anon_class->new( simple => $reject ); + }, + "got exception passing $described to constructor with $name" + ); + + ok( + exception { + $anon_class->new()->add_to_collection($reject); + }, + "got exception passing $described to native trait push method with $name" + ); + } +} + +sub describe { + my $val = shift; + + return 'undef' unless defined $val; + + if ( !ref $val ) { + return q{''} if $val eq q{}; + + $val =~ s/\n/\\n/g; + + return $val; + } + + return 'open filehandle' + if openhandle $val && !blessed $val; + + return blessed $val + ? ( ref $val ) . ' object' + : ( ref $val ) . ' reference'; +} diff --git a/t/type_constraints/util_type_coercion.t b/t/type_constraints/util_type_coercion.t new file mode 100644 index 0000000..a066a76 --- /dev/null +++ b/t/type_constraints/util_type_coercion.t @@ -0,0 +1,100 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package HTTPHeader; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + +coerce Header + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + +my $header = HTTPHeader->new(); +isa_ok($header, 'HTTPHeader'); + +ok(Header($header), '... this passed the type test'); +ok(!Header([]), '... this did not pass the type test'); +ok(!Header({}), '... this did not pass the type test'); + +my $anon_type = subtype Object => where { $_->isa('HTTPHeader') }; + +is( exception { + coerce $anon_type + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; +}, undef, 'coercion of anonymous subtype succeeds' ); + +foreach my $coercion ( + find_type_constraint('Header')->coercion, + $anon_type->coercion + ) { + + isa_ok($coercion, 'Moose::Meta::TypeCoercion'); + + { + my $coerced = $coercion->coerce([ 1, 2, 3 ]); + isa_ok($coerced, 'HTTPHeader'); + + is_deeply( + $coerced->array(), + [ 1, 2, 3 ], + '... got the right array'); + is($coerced->hash(), undef, '... nothing assigned to the hash'); + } + + { + my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 }); + isa_ok($coerced, 'HTTPHeader'); + + is_deeply( + $coerced->hash(), + { one => 1, two => 2, three => 3 }, + '... got the right hash'); + is($coerced->array(), undef, '... nothing assigned to the array'); + } + + { + my $scalar_ref = \(my $var); + my $coerced = $coercion->coerce($scalar_ref); + is($coerced, $scalar_ref, '... got back what we put in'); + } + + { + my $coerced = $coercion->coerce("Foo"); + is($coerced, "Foo", '... got back what we put in'); + } +} + +subtype 'StrWithTrailingX' + => as 'Str' + => where { /X$/ }; + +coerce 'StrWithTrailingX' + => from 'Str' + => via { $_ . 'X' }; + +my $tc = find_type_constraint('StrWithTrailingX'); +is($tc->coerce("foo"), "fooX", "coerce when needed"); +is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded"); + +done_testing; diff --git a/t/type_constraints/util_type_constraints.t b/t/type_constraints/util_type_constraints.t new file mode 100644 index 0000000..6eededc --- /dev/null +++ b/t/type_constraints/util_type_constraints.t @@ -0,0 +1,233 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util (); + +use Moose::Util::TypeConstraints; + + +type Number => where { Scalar::Util::looks_like_number($_) }; +type String + => where { !ref($_) && !Number($_) } + => message { "This is not a string ($_)" }; + +subtype Natural + => as Number + => where { $_ > 0 }; + +subtype NaturalLessThanTen + => as Natural + => where { $_ < 10 } + => message { "The number '$_' is not less than 10" }; + +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(Number(5), '... this is a Num'); +ok(!defined(Number('Foo')), '... this is not a Num'); +{ + my $number_tc = Moose::Util::TypeConstraints::find_type_constraint('Number'); + is("$number_tc", 'Number', '... type constraint stringifies to name'); +} + +ok(String('Foo'), '... this is a Str'); +ok(!defined(String(5)), '... this is not a Str'); + +ok(Natural(5), '... this is a Natural'); +is(Natural(-5), undef, '... this is not a Natural'); +is(Natural('Foo'), undef, '... this is not a Natural'); + +ok(NaturalLessThanTen(5), '... this is a NaturalLessThanTen'); +is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen'); +is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen'); +is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen'); + +# anon sub-typing + +my $negative = subtype Number => where { $_ < 0 }; +ok(defined $negative, '... got a value back from negative'); +isa_ok($negative, 'Moose::Meta::TypeConstraint'); + +ok($negative->check(-5), '... this is a negative number'); +ok(!defined($negative->check(5)), '... this is not a negative number'); +is($negative->check('Foo'), undef, '... this is not a negative number'); + +ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number'); +ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String'); + +my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"}; + +ok(defined $negative2, '... got a value back from negative'); +isa_ok($negative2, 'Moose::Meta::TypeConstraint'); + +ok($negative2->check(-5), '... this is a negative number'); +ok(!defined($negative2->check(5)), '... this is not a negative number'); +is($negative2->check('Foo'), undef, '... this is not a negative number'); + +ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number'); +ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String'); + +ok($negative2->has_message, '... it has a message'); +is($negative2->validate(2), + '2 is not a negative number', + '... validated unsuccessfully (got error)'); + +# check some meta-details + +my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen'); +isa_ok($natural_less_than_ten, 'Moose::Meta::TypeConstraint'); + +ok($natural_less_than_ten->is_subtype_of('Natural'), '... NaturalLessThanTen is subtype of Natural'); +ok($natural_less_than_ten->is_subtype_of('Number'), '... NaturalLessThanTen is subtype of Number'); +ok(!$natural_less_than_ten->is_subtype_of('String'), '... NaturalLessThanTen is not subtype of String'); + +ok($natural_less_than_ten->has_message, '... it has a message'); + +ok(!defined($natural_less_than_ten->validate(5)), '... validated successfully (no error)'); + +is($natural_less_than_ten->validate(15), + "The number '15' is not less than 10", + '... validated unsuccessfully (got error)'); + +my $natural = find_type_constraint('Natural'); +isa_ok($natural, 'Moose::Meta::TypeConstraint'); + +ok($natural->is_subtype_of('Number'), '... Natural is a subtype of Number'); +ok(!$natural->is_subtype_of('String'), '... Natural is not a subtype of String'); + +ok(!$natural->has_message, '... it does not have a message'); + +ok(!defined($natural->validate(5)), '... validated successfully (no error)'); + +is($natural->validate(-5), + "Validation failed for 'Natural' with value -5", + '... validated unsuccessfully (got error)'); + +my $string = find_type_constraint('String'); +isa_ok($string, 'Moose::Meta::TypeConstraint'); + +ok($string->has_message, '... it does have a message'); + +ok(!defined($string->validate("Five")), '... validated successfully (no error)'); + +is($string->validate(5), +"This is not a string (5)", +'... validated unsuccessfully (got error)'); + +is( exception { Moose::Meta::Attribute->new('bob', isa => 'Spong') }, undef, 'meta-attr construction ok even when type constraint utils loaded first' ); + +# Test type constraint predicate return values. + +foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) { + ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint"); +} + +# Test adding things which don't look like types to the registry throws an exception + +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; +like( exception {$r->add_type_constraint()}, qr/not a valid type constraint/, '->add_type_constraint(undef) throws' ); +like( exception {$r->add_type_constraint('foo')}, qr/not a valid type constraint/, '->add_type_constraint("foo") throws' ); +like( exception {$r->add_type_constraint(bless {}, 'SomeClass')}, qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws' ); + +# Test some specific things that in the past did not work, +# specifically weird variations on anon subtypes. + +{ + my $subtype = subtype as 'Str'; + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); + # This test sucks but is the best we can do + is( $subtype->constraint->(), 1, + 'subtype has the null constraint' ); + ok( ! $subtype->has_message, 'subtype has no message' ); +} + +{ + my $subtype = subtype as 'ArrayRef[Num|Str]'; + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); + ok( ! $subtype->has_message, 'subtype has no message' ); +} + +{ + my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' }; + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); + ok( $subtype->has_message, 'subtype does have a message' ); +} + +# alternative sugar-less calling style which is documented as legit: +{ + my $subtype = subtype( 'MyStr', { as => 'Str' } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, 'MyStr', 'name is MyStr' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); +} + +{ + my $subtype = subtype( { as => 'Str' } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, '__ANON__', 'name is __ANON__' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); +} + +{ + my $subtype = subtype( { as => 'Str', where => sub { /X/ } } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, '__ANON__', 'name is __ANON__' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); + ok( $subtype->check('FooX'), 'constraint accepts FooX' ); + ok( ! $subtype->check('Foo'), 'constraint reject Foo' ); +} + +{ + like( exception { subtype 'Foo' }, qr/cannot consist solely of a name/, 'Cannot call subtype with a single string argument' ); +} + +{ + my $subtype = subtype( { as => 'Num' } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + + my @rejects = ( 'nan', + 'inf', + 'infinity', + 'Infinity', + 'NaN', + 'INF', + ' 1234 ', + ' 123.44 ', + ' 13e7 ', + 'hello', + "1e3\n", + "52563\n", + "123.4\n", + '0.', + "0 but true", + undef + ); + my @accepts = ( '123', + '123.4367', + '3322', + '13e7', + '0', + '0.0', + '.0', + .0, + 0.0, + 123, + 13e6, + 123.4367, + 10.5 + ); + + for( @rejects ) + { + my $printable = defined $_ ? $_ : "(undef)"; + ok( !$subtype->check($_), "constraint rejects $printable" ) + } + ok( $subtype->check($_), "constraint accepts $_" ) for @accepts; +} + +done_testing; diff --git a/t/type_constraints/util_type_constraints_export.t b/t/type_constraints/util_type_constraints_export.t new file mode 100644 index 0000000..0671bf9 --- /dev/null +++ b/t/type_constraints/util_type_constraints_export.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + + use Moose::Util::TypeConstraints; + + eval { + type MyRef => where { ref($_) }; + }; + ::ok( !$@, '... successfully exported &type to Foo package' ); + + eval { + subtype MyArrayRef => as MyRef => where { ref($_) eq 'ARRAY' }; + }; + ::ok( !$@, '... successfully exported &subtype to Foo package' ); + + Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + + ::ok( MyRef( {} ), '... Ref worked correctly' ); + ::ok( MyArrayRef( [] ), '... ArrayRef worked correctly' ); +} + +done_testing; diff --git a/t/type_constraints/util_type_reloading.t b/t/type_constraints/util_type_reloading.t new file mode 100644 index 0000000..729cdc4 --- /dev/null +++ b/t/type_constraints/util_type_reloading.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; + + +$SIG{__WARN__} = sub { 0 }; + +eval { require Foo; }; +ok(!$@, '... loaded Foo successfully') || diag $@; + +delete $INC{'Foo.pm'}; + +eval { require Foo; }; +ok(!$@, '... re-loaded Foo successfully') || diag $@; + +eval { require Bar; }; +ok(!$@, '... loaded Bar successfully') || diag $@; + +delete $INC{'Bar.pm'}; + +eval { require Bar; }; +ok(!$@, '... re-loaded Bar successfully') || diag $@; + +done_testing; diff --git a/t/type_constraints/with-specio.t b/t/type_constraints/with-specio.t new file mode 100644 index 0000000..ef442d1 --- /dev/null +++ b/t/type_constraints/with-specio.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::Moose qw( with_immutable ); +use Test::More; + +BEGIN { + plan skip_all => 'These tests requires Specio, which requires perl 5.010' + unless $] >= 5.010; +} + +use Test::Requires { + 'Specio::Declare' => '0.10', + 'Specio::Library::Builtins' => '0.10', +}; + +{ + package Foo; + + use Moose; + use Specio::Library::Builtins; + + has int => ( + is => 'ro', + isa => t('Int'), + ); + + has array_of_ints => ( + is => 'ro', + isa => t( 'ArrayRef', of => t('Int') ), + ); + + has hash_of_ints => ( + is => 'ro', + isa => t( 'HashRef', of => t('Int') ), + ); +} + +with_immutable( + sub { + my $is_immutable = shift; + subtest( + 'Foo class' . ( $is_immutable ? ' (immutable)' : q{} ), + sub { + + is( + exception { Foo->new( int => 42 ) }, + undef, + '42 is an acceptable int' + ); + + like( + exception { Foo->new( int => 42.4 ) }, + qr/does not pass the type constraint.+for type named Int/, + '42.4 is not an acceptable int' + ); + + is( + exception { Foo->new( array_of_ints => [ 42, 84 ] ) }, + undef, + '[ 42, 84 ] is an acceptable array of ints' + ); + + like( + exception { Foo->new( array_of_ints => [ 42.4, 84 ] ) }, + qr/does not pass the type constraint.+for anonymous type/, + '[ 42.4, 84 ] is an acceptable array of ints' + ); + + is( + exception { + Foo->new( hash_of_ints => { foo => 42, bar => 84 } ); + }, + undef, + '{ foo => 42, bar => 84 } is an acceptable array of ints' + ); + + like( + exception { + Foo->new( + hash_of_ints => { foo => 42.4, bar => 84 } ); + }, + qr/does not pass the type constraint.+for anonymous type/, + '{ foo => 42.4, bar => 84 } is an acceptable array of ints' + ); + } + ); + }, + 'Foo' +); + +{ + package Bar; + + use Moose; + use Specio::Declare; + use Specio::Library::Builtins; + + my $array_of_ints = anon( parent => t( 'ArrayRef', of => t('Int') ) ); + + coerce( + $array_of_ints, + from => t('Int'), + using => sub { + return [ $_[0] ]; + } + ); + + has array_of_ints => ( + is => 'ro', + isa => $array_of_ints, + coerce => 1, + ); + + my $hash_of_ints = anon( parent => t( 'HashRef', of => t('Int') ) ); + + coerce( + $hash_of_ints, + from => t('Int'), + using => sub { + return { foo => $_[0] }; + } + ); + + has hash_of_ints => ( + is => 'ro', + isa => $hash_of_ints, + coerce => 1, + ); +} + +with_immutable( + sub { + my $is_immutable = shift; + subtest( + 'Bar class' . ( $is_immutable ? ' (immutable)' : q{} ), + sub { + + is( + exception { Bar->new( array_of_ints => [ 42, 84 ] ) }, + undef, + '[ 42, 84 ] is an acceptable array of ints' + ); + + like( + exception { Bar->new( array_of_ints => [ 42.4, 84 ] ) }, + qr/does not pass the type constraint.+for anonymous type/, + '[ 42.4, 84 ] is an acceptable array of ints' + ); + + { + my $bar; + is( + exception { $bar = Bar->new( array_of_ints => 42 ) }, + undef, + '42 is an acceptable array of ints with coercion' + ); + + is_deeply( + $bar->array_of_ints(), + [42], + 'int is coerced to single element arrayref' + ); + } + + is( + exception { + Bar->new( hash_of_ints => { foo => 42, bar => 84 } ); + }, + undef, + '{ foo => 42, bar => 84 } is an acceptable array of ints' + ); + + like( + exception { + Bar->new( + hash_of_ints => { foo => 42.4, bar => 84 } ); + }, + qr/does not pass the type constraint.+for anonymous type/, + '{ foo => 42.4, bar => 84 } is an acceptable array of ints' + ); + + { + my $bar; + is( + exception { $bar = Bar->new( hash_of_ints => 42 ) }, + undef, + '42 is an acceptable hash of ints with coercion' + ); + + is_deeply( + $bar->hash_of_ints(), + { foo => 42 }, + 'int is coerced to single element hashref' + ); + } + } + ); + }, + 'Bar' +); + +done_testing(); diff --git a/t/zzz-check-breaks.t b/t/zzz-check-breaks.t new file mode 100644 index 0000000..86e2f88 --- /dev/null +++ b/t/zzz-check-breaks.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::CheckBreaks 0.012 + +use Test::More 0.88; + +SKIP: { + eval 'require Moose::Conflicts; Moose::Conflicts->check_conflicts'; + skip('no Moose::Conflicts module found', 1) if not $INC{'Moose/Conflicts.pm'}; + + diag $@ if $@; + pass 'conflicts checked via Moose::Conflicts'; +} + +my $breaks = { + "Catalyst" => "<= 5.90049999", + "Config::MVP" => "<= 2.200004", + "Devel::REPL" => "<= 1.003020", + "Dist::Zilla::Plugin::Git" => "<= 2.016", + "Fey" => "<= 0.36", + "Fey::ORM" => "<= 0.42", + "File::ChangeNotify" => "<= 0.15", + "HTTP::Throwable" => "<= 0.017", + "KiokuDB" => "<= 0.51", + "Markdent" => "<= 0.16", + "Mason" => "<= 2.18", + "MooseX::ABC" => "<= 0.05", + "MooseX::Aliases" => "<= 0.08", + "MooseX::AlwaysCoerce" => "<= 0.13", + "MooseX::App" => "<= 1.22", + "MooseX::Attribute::Deflator" => "<= 2.1.7", + "MooseX::Attribute::Dependent" => "<= 1.1.0", + "MooseX::Attribute::Prototype" => "<= 0.10", + "MooseX::AttributeHelpers" => "<= 0.22", + "MooseX::AttributeIndexes" => "<= 1.0.0", + "MooseX::AttributeInflate" => "<= 0.02", + "MooseX::CascadeClearing" => "<= 0.03", + "MooseX::ClassAttribute" => "<= 0.26", + "MooseX::Constructor::AllErrors" => "<= 0.021", + "MooseX::Declare" => "<= 0.35", + "MooseX::FollowPBP" => "<= 0.02", + "MooseX::Getopt" => "<= 0.56", + "MooseX::InstanceTracking" => "<= 0.04", + "MooseX::LazyRequire" => "<= 0.06", + "MooseX::Meta::Attribute::Index" => "<= 0.04", + "MooseX::Meta::Attribute::Lvalue" => "<= 0.05", + "MooseX::Method::Signatures" => "<= 0.44", + "MooseX::MethodAttributes" => "<= 0.22", + "MooseX::NonMoose" => "<= 0.24", + "MooseX::Object::Pluggable" => "<= 0.0011", + "MooseX::POE" => "<= 0.214", + "MooseX::Params::Validate" => "<= 0.05", + "MooseX::PrivateSetters" => "<= 0.03", + "MooseX::Role::Cmd" => "<= 0.06", + "MooseX::Role::Parameterized" => "<= 1.00", + "MooseX::Role::WithOverloading" => "<= 0.14", + "MooseX::Runnable" => "<= 0.03", + "MooseX::Scaffold" => "<= 0.05", + "MooseX::SemiAffordanceAccessor" => "<= 0.05", + "MooseX::SetOnce" => "<= 0.100473", + "MooseX::Singleton" => "<= 0.25", + "MooseX::SlurpyConstructor" => "<= 1.1", + "MooseX::Storage" => "<= 0.42", + "MooseX::StrictConstructor" => "<= 0.12", + "MooseX::Traits" => "<= 0.11", + "MooseX::Types" => "<= 0.19", + "MooseX::Types::Parameterizable" => "<= 0.05", + "MooseX::Types::Set::Object" => "<= 0.03", + "MooseX::Types::Signal" => "<= 1.101930", + "MooseX::UndefTolerant" => "<= 0.11", + "PRANG" => "<= 0.14", + "Pod::Elemental" => "<= 0.093280", + "Pod::Weaver" => "<= 3.101638", + "Reaction" => "<= 0.002003", + "Test::Able" => "<= 0.10", + "Test::CleanNamespaces" => "<= 0.03", + "Test::Moose::More" => "<= 0.022", + "Test::TempDir" => "<= 0.05", + "Throwable" => "<= 0.102080", + "namespace::autoclean" => "<= 0.08" +}; + +use CPAN::Meta::Requirements; +my $reqs = CPAN::Meta::Requirements->new; +$reqs->add_string_requirement($_, $breaks->{$_}) foreach keys %$breaks; + +use CPAN::Meta::Check 0.007 'check_requirements'; +our $result = check_requirements($reqs, 'conflicts'); + +if (my @breaks = grep { defined $result->{$_} } keys %$result) +{ + diag 'Breakages found with Moose:'; + diag "$result->{$_}" for sort @breaks; + diag "\n", 'You should now update these modules!'; +} + +done_testing; diff --git a/xs/Attribute.xs b/xs/Attribute.xs new file mode 100644 index 0000000..6314af8 --- /dev/null +++ b/xs/Attribute.xs @@ -0,0 +1,9 @@ +#include "mop.h" + +MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Attribute, associated_class); + INSTALL_SIMPLE_READER(Attribute, associated_methods); diff --git a/xs/AttributeCore.xs b/xs/AttributeCore.xs new file mode 100644 index 0000000..d495a16 --- /dev/null +++ b/xs/AttributeCore.xs @@ -0,0 +1,18 @@ +#include "mop.h" + +MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Mixin::AttributeCore, name); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, accessor); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, reader); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, writer); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, predicate); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, clearer); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, builder); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, init_arg); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, initializer); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, definition_context); + INSTALL_SIMPLE_READER(Mixin::AttributeCore, insertion_order); diff --git a/xs/Class.xs b/xs/Class.xs new file mode 100644 index 0000000..5c5d5c9 --- /dev/null +++ b/xs/Class.xs @@ -0,0 +1,12 @@ +#include "mop.h" + +MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Class, instance_metaclass); + INSTALL_SIMPLE_READER(Class, immutable_trait); + INSTALL_SIMPLE_READER(Class, constructor_class); + INSTALL_SIMPLE_READER(Class, constructor_name); + INSTALL_SIMPLE_READER(Class, destructor_class); diff --git a/xs/Generated.xs b/xs/Generated.xs new file mode 100644 index 0000000..57db324 --- /dev/null +++ b/xs/Generated.xs @@ -0,0 +1,9 @@ +#include "mop.h" + +MODULE = Class::MOP::Method::Generated PACKAGE = Class::MOP::Method::Generated + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Method::Generated, is_inline); + INSTALL_SIMPLE_READER(Method::Generated, definition_context); diff --git a/xs/HasAttributes.xs b/xs/HasAttributes.xs new file mode 100644 index 0000000..dc59227 --- /dev/null +++ b/xs/HasAttributes.xs @@ -0,0 +1,9 @@ +#include "mop.h" + +MODULE = Class::MOP::Mixin::HasAttributes PACKAGE = Class::MOP::Mixin::HasAttributes + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Mixin::HasAttributes, attribute_metaclass); + INSTALL_SIMPLE_READER_WITH_KEY(Mixin::HasAttributes, _attribute_map, attributes); diff --git a/xs/HasMethods.xs b/xs/HasMethods.xs new file mode 100644 index 0000000..e136abe --- /dev/null +++ b/xs/HasMethods.xs @@ -0,0 +1,88 @@ +#include "mop.h" + +SV *mop_method_metaclass; +SV *mop_associated_metaclass; +SV *mop_wrap; + +static void +mop_update_method_map(pTHX_ HV *const stash, HV *const map) +{ + char *method_name; + I32 method_name_len; + SV *method; + HV *symbols; + + symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE); + sv_2mortal((SV*)symbols); + + (void)hv_iterinit(map); + while ((method = hv_iternextsv(map, &method_name, &method_name_len))) { + SV *body; + SV *stash_slot; + + if (!SvROK(method)) { + continue; + } + + if (sv_isobject(method)) { + /* $method_object->body() */ + body = mop_call0(aTHX_ method, KEY_FOR(body)); + } + else { + body = method; + } + + stash_slot = *hv_fetch(symbols, method_name, method_name_len, TRUE); + if (SvROK(stash_slot) && ((CV*)SvRV(body)) == ((CV*)SvRV(stash_slot))) { + continue; + } + + /* delete $map->{$method_name} */ + (void)hv_delete(map, method_name, method_name_len, G_DISCARD); + } +} + +MODULE = Class::MOP::Mixin::HasMethods PACKAGE = Class::MOP::Mixin::HasMethods + +PROTOTYPES: DISABLE + +void +_method_map(self) + SV *self + PREINIT: + HV *const obj = (HV *)SvRV(self); + SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) ); + HV *const stash = gv_stashsv(class_name, 0); + UV current; + SV *cache_flag; + SV *map_ref; + PPCODE: + if (!stash) { + mXPUSHs(newRV_noinc((SV *)newHV())); + return; + } + + current = mop_check_package_cache_flag(aTHX_ stash); + cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag))); + map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods))); + + /* $self->{methods} does not yet exist (or got deleted) */ + if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) { + SV *new_map_ref = newRV_noinc((SV *)newHV()); + sv_2mortal(new_map_ref); + sv_setsv(map_ref, new_map_ref); + } + + if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) { + mop_update_method_map(aTHX_ stash, (HV *)SvRV(map_ref)); + sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */ + } + + XPUSHs(map_ref); + +BOOT: + mop_method_metaclass = newSVpvs("method_metaclass"); + mop_associated_metaclass = newSVpvs("associated_metaclass"); + mop_wrap = newSVpvs("wrap"); + INSTALL_SIMPLE_READER(Mixin::HasMethods, method_metaclass); + INSTALL_SIMPLE_READER(Mixin::HasMethods, wrapped_method_metaclass); diff --git a/xs/Inlined.xs b/xs/Inlined.xs new file mode 100644 index 0000000..a7f1f56 --- /dev/null +++ b/xs/Inlined.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Method::Inlined PACKAGE = Class::MOP::Method::Inlined + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Method::Inlined, _expected_method_class); diff --git a/xs/Instance.xs b/xs/Instance.xs new file mode 100644 index 0000000..944caed --- /dev/null +++ b/xs/Instance.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Instance, associated_metaclass); diff --git a/xs/MOP.xs b/xs/MOP.xs new file mode 100644 index 0000000..0bf05dc --- /dev/null +++ b/xs/MOP.xs @@ -0,0 +1,21 @@ +#include "mop.h" + +MODULE = Class::MOP PACKAGE = Class::MOP + +PROTOTYPES: DISABLE + +# use prototype here to be compatible with get_code_info from Sub::Identify +void +get_code_info(coderef) + SV *coderef + PROTOTYPE: $ + PREINIT: + char *pkg = NULL; + char *name = NULL; + PPCODE: + SvGETMAGIC(coderef); + if (mop_get_code_info(coderef, &pkg, &name)) { + EXTEND(SP, 2); + mPUSHs(newSVpv(pkg, 0)); + mPUSHs(newSVpv(name, 0)); + } diff --git a/xs/Method.xs b/xs/Method.xs new file mode 100644 index 0000000..5ffa467 --- /dev/null +++ b/xs/Method.xs @@ -0,0 +1,23 @@ +#include "mop.h" + +MODULE = Class::MOP::Method PACKAGE = Class::MOP::Method + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Method, name); + INSTALL_SIMPLE_READER(Method, package_name); + INSTALL_SIMPLE_READER(Method, body); + +bool +is_stub(self) + SV *self + + PREINIT: + CV *const body = (CV *)SvRV( HeVAL( hv_fetch_ent((HV *)SvRV(self), KEY_FOR(body), 0, HASH_FOR(body)) ) ); + + CODE: + RETVAL = !( CvISXSUB(body) || CvROOT(body) ); + + OUTPUT: + RETVAL diff --git a/xs/Moose.xs b/xs/Moose.xs new file mode 100644 index 0000000..22686cd --- /dev/null +++ b/xs/Moose.xs @@ -0,0 +1,170 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" +#include "mop.h" + +#ifndef MGf_COPY +# define MGf_COPY 0 +#endif + +#ifndef MGf_DUP +# define MGf_DUP 0 +#endif + +#ifndef MGf_LOCAL +# define MGf_LOCAL 0 +#endif + +STATIC int unset_export_flag (pTHX_ SV *sv, MAGIC *mg); + +STATIC MGVTBL export_flag_vtbl = { + NULL, /* get */ + unset_export_flag, /* set */ + NULL, /* len */ + NULL, /* clear */ + NULL, /* free */ +#if MGf_COPY + NULL, /* copy */ +#endif +#if MGf_DUP + NULL, /* dup */ +#endif +#if MGf_LOCAL + NULL, /* local */ +#endif +}; + +STATIC bool +export_flag_is_set (pTHX_ SV *sv) +{ + MAGIC *mg, *moremagic; + + if (SvTYPE(SvRV(sv)) != SVt_PVGV) { + return 0; + } + + for (mg = SvMAGIC(SvRV(sv)); mg; mg = moremagic) { + moremagic = mg->mg_moremagic; + + if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &export_flag_vtbl) { + break; + } + } + + return !!mg; +} + +STATIC int +unset_export_flag (pTHX_ SV *sv, MAGIC *mymg) +{ + MAGIC *mg, *prevmagic = NULL, *moremagic = NULL; + + for (mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) { + moremagic = mg->mg_moremagic; + + if (mg == mymg) { + break; + } + } + + if (!mg) { + return 0; + } + + if (prevmagic) { + prevmagic->mg_moremagic = moremagic; + } + else { + SvMAGIC_set(sv, moremagic); + } + + mg->mg_moremagic = NULL; + + Safefree (mg); + + return 0; +} + +#ifndef SvRXOK +/* SvRXOK appeared before SVt_REGEXP did, so this implementation assumes magic + * based qr//. Note re::is_regexp isn't in 5.8, hence the need for this XS. + */ +#define SvRXOK(sv) is_regexp(aTHX_ sv) + +STATIC int +is_regexp (pTHX_ SV* sv) { + SV* tmpsv; + + if (SvMAGICAL(sv)) { + mg_get(sv); + } + + if (SvROK(sv) && + (tmpsv = (SV*) SvRV(sv)) && + SvTYPE(tmpsv) == SVt_PVMG && + (mg_find(tmpsv, PERL_MAGIC_qr))) { + return TRUE; + } + + return FALSE; +} +#endif + +XS_EXTERNAL(boot_Class__MOP); +XS_EXTERNAL(boot_Class__MOP__Mixin__HasAttributes); +XS_EXTERNAL(boot_Class__MOP__Mixin__HasMethods); +XS_EXTERNAL(boot_Class__MOP__Package); +XS_EXTERNAL(boot_Class__MOP__Mixin__AttributeCore); +XS_EXTERNAL(boot_Class__MOP__Method); +XS_EXTERNAL(boot_Class__MOP__Method__Inlined); +XS_EXTERNAL(boot_Class__MOP__Method__Generated); +XS_EXTERNAL(boot_Class__MOP__Class); +XS_EXTERNAL(boot_Class__MOP__Attribute); +XS_EXTERNAL(boot_Class__MOP__Instance); +XS_EXTERNAL(boot_Moose__Meta__Role__Application__ToInstance); + +MODULE = Moose PACKAGE = Moose::Exporter + +PROTOTYPES: DISABLE + +BOOT: + mop_prehash_keys(); + + MOP_CALL_BOOT (boot_Class__MOP); + MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasAttributes); + MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasMethods); + MOP_CALL_BOOT (boot_Class__MOP__Package); + MOP_CALL_BOOT (boot_Class__MOP__Mixin__AttributeCore); + MOP_CALL_BOOT (boot_Class__MOP__Method); + MOP_CALL_BOOT (boot_Class__MOP__Method__Inlined); + MOP_CALL_BOOT (boot_Class__MOP__Method__Generated); + MOP_CALL_BOOT (boot_Class__MOP__Class); + MOP_CALL_BOOT (boot_Class__MOP__Attribute); + MOP_CALL_BOOT (boot_Class__MOP__Instance); + MOP_CALL_BOOT (boot_Moose__Meta__Role__Application__ToInstance); + +void +_flag_as_reexport (SV *sv) + CODE: + sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, &export_flag_vtbl, NULL, 0); + +bool +_export_is_flagged (SV *sv) + CODE: + RETVAL = export_flag_is_set(aTHX_ sv); + OUTPUT: + RETVAL + +MODULE = Moose PACKAGE = Moose::Util::TypeConstraints::Builtins + +bool +_RegexpRef (SV *sv=NULL) + INIT: + if (!items) { + sv = DEFSV; + } + CODE: + RETVAL = SvRXOK(sv); + OUTPUT: + RETVAL diff --git a/xs/Package.xs b/xs/Package.xs new file mode 100644 index 0000000..6c47099 --- /dev/null +++ b/xs/Package.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package); diff --git a/xs/ToInstance.xs b/xs/ToInstance.xs new file mode 100644 index 0000000..044d2f3 --- /dev/null +++ b/xs/ToInstance.xs @@ -0,0 +1,63 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +static void +S_reset_amagic (pTHX_ SV *rv, const bool on) +{ + /* It is assumed that you've already turned magic on/off on rv */ + + SV *sva; + SV *const target = SvRV (rv); + + /* Less 1 for the reference we've already dealt with. */ + U32 how_many = SvREFCNT (target) - 1; + MAGIC *mg; + + if (SvMAGICAL (target) && (mg = mg_find (target, PERL_MAGIC_backref))) { + /* Back references also need to be found, but aren't part of the target's reference count. */ + how_many += 1 + av_len ((AV *)mg->mg_obj); + } + + if (!how_many) { + /* There was only 1 reference to this object. */ + return; + } + + for (sva = PL_sv_arenaroot; sva; sva = (SV *)SvANY (sva)) { + register const SV *const svend = &sva[SvREFCNT (sva)]; + register SV *sv; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE (sv) != SVTYPEMASK + && ((sv->sv_flags & SVf_ROK) == SVf_ROK) + && SvREFCNT (sv) + && SvRV (sv) == target + && sv != rv) { + if (on) { + SvAMAGIC_on (sv); + } + else { + SvAMAGIC_off (sv); + } + + if (--how_many == 0) { + /* We have found them all. */ + return; + } + } + } + } +} + +MODULE = Moose::Meta::Role::Application::ToInstance PACKAGE = Moose::Meta::Role::Application::ToInstance + +PROTOTYPES: DISABLE + +void +_reset_amagic (rv) + SV *rv + CODE: + if (Gv_AMG (SvSTASH (SvRV (rv))) && !SvAMAGIC (rv)) { + SvAMAGIC_on (rv); + S_reset_amagic (aTHX_ rv, TRUE); + } diff --git a/xs/typemap b/xs/typemap new file mode 100644 index 0000000..7ab39e1 --- /dev/null +++ b/xs/typemap @@ -0,0 +1,17 @@ +type_filter_t T_TYPE_FILTER + +INPUT + +T_TYPE_FILTER + { + const char *__tMp = SvPV_nolen($arg); + switch (*__tMp) { + case 'C': $var = TYPE_FILTER_CODE; break; + case 'A': $var = TYPE_FILTER_ARRAY; break; + case 'I': $var = TYPE_FILTER_IO; break; + case 'H': $var = TYPE_FILTER_HASH; break; + case 'S': $var = TYPE_FILTER_SCALAR; break; + default: + croak(\"Unknown type %s\\n\", __tMp); + } + } diff --git a/xt/author/authority.t b/xt/author/authority.t new file mode 100644 index 0000000..5cf61f7 --- /dev/null +++ b/xt/author/authority.t @@ -0,0 +1,15 @@ +use strict; +use warnings; + +use Test::More; +BEGIN { + plan skip_all => 'this test requires a built dist' + unless -f 'MANIFEST' && -f 'META.json'; +} + +use Moose (); + +# this is used in Moo::sification +ok(defined $Moose::AUTHORITY, '$AUTHORITY is set in the main module'); + +done_testing; diff --git a/xt/author/debugger-duck_type.t b/xt/author/debugger-duck_type.t new file mode 100644 index 0000000..76e3ee9 --- /dev/null +++ b/xt/author/debugger-duck_type.t @@ -0,0 +1,17 @@ + +use FindBin qw/ $Bin /; + +BEGIN { +#line 1 +#!/usr/bin/perl -d + + push @DB::typeahead, "c", "q"; + + # try to shut it up at least a little bit + open my $out, ">", \my $out_buf; + $DB::OUT = $out; + open my $in, "<", \my $in_buf; + $DB::IN = $in; +} + +require "$Bin/../../t/type_constraints/duck_types.t"; diff --git a/xt/author/eol.t b/xt/author/eol.t new file mode 100644 index 0000000..58dcd18 --- /dev/null +++ b/xt/author/eol.t @@ -0,0 +1,969 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.18 + +use Test::More 0.88; +use Test::EOL; + +my @files = ( + 'bin/moose-outdated', + 'lib/Class/MOP.pm', + 'lib/Class/MOP/Attribute.pm', + 'lib/Class/MOP/Class.pm', + 'lib/Class/MOP/Class/Immutable/Trait.pm', + 'lib/Class/MOP/Deprecated.pm', + 'lib/Class/MOP/Instance.pm', + 'lib/Class/MOP/Method.pm', + 'lib/Class/MOP/Method/Accessor.pm', + 'lib/Class/MOP/Method/Constructor.pm', + 'lib/Class/MOP/Method/Generated.pm', + 'lib/Class/MOP/Method/Inlined.pm', + 'lib/Class/MOP/Method/Meta.pm', + 'lib/Class/MOP/Method/Wrapped.pm', + 'lib/Class/MOP/MiniTrait.pm', + 'lib/Class/MOP/Mixin.pm', + 'lib/Class/MOP/Mixin/AttributeCore.pm', + 'lib/Class/MOP/Mixin/HasAttributes.pm', + 'lib/Class/MOP/Mixin/HasMethods.pm', + 'lib/Class/MOP/Mixin/HasOverloads.pm', + 'lib/Class/MOP/Module.pm', + 'lib/Class/MOP/Object.pm', + 'lib/Class/MOP/Overload.pm', + 'lib/Class/MOP/Package.pm', + 'lib/Moose.pm', + 'lib/Moose/Conflicts.pm', + 'lib/Moose/Cookbook.pod', + 'lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod', + 'lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod', + 'lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod', + 'lib/Moose/Cookbook/Basics/Company_Subtypes.pod', + 'lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod', + 'lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod', + 'lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod', + 'lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod', + 'lib/Moose/Cookbook/Basics/Immutable.pod', + 'lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod', + 'lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod', + 'lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod', + 'lib/Moose/Cookbook/Extending/ExtensionOverview.pod', + 'lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod', + 'lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod', + 'lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod', + 'lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod', + 'lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod', + 'lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod', + 'lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod', + 'lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod', + 'lib/Moose/Cookbook/Meta/WhyMeta.pod', + 'lib/Moose/Cookbook/Roles/ApplicationToInstance.pod', + 'lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod', + 'lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod', + 'lib/Moose/Cookbook/Snack/Keywords.pod', + 'lib/Moose/Cookbook/Snack/Types.pod', + 'lib/Moose/Cookbook/Style.pod', + 'lib/Moose/Deprecated.pm', + 'lib/Moose/Exception.pm', + 'lib/Moose/Exception/AccessorMustReadWrite.pm', + 'lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm', + 'lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm', + 'lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm', + 'lib/Moose/Exception/ApplyTakesABlessedInstance.pm', + 'lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm', + 'lib/Moose/Exception/AttributeConflictInRoles.pm', + 'lib/Moose/Exception/AttributeConflictInSummation.pm', + 'lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm', + 'lib/Moose/Exception/AttributeIsRequired.pm', + 'lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm', + 'lib/Moose/Exception/AttributeNamesDoNotMatch.pm', + 'lib/Moose/Exception/AttributeValueIsNotAnObject.pm', + 'lib/Moose/Exception/AttributeValueIsNotDefined.pm', + 'lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm', + 'lib/Moose/Exception/BadOptionFormat.pm', + 'lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm', + 'lib/Moose/Exception/BuilderDoesNotExist.pm', + 'lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm', + 'lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm', + 'lib/Moose/Exception/BuilderMustBeAMethodName.pm', + 'lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm', + 'lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm', + 'lib/Moose/Exception/CanExtendOnlyClasses.pm', + 'lib/Moose/Exception/CanOnlyConsumeRole.pm', + 'lib/Moose/Exception/CanOnlyWrapBlessedCode.pm', + 'lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm', + 'lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm', + 'lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm', + 'lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm', + 'lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm', + 'lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm', + 'lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm', + 'lib/Moose/Exception/CannotAugmentNoSuperMethod.pm', + 'lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm', + 'lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm', + 'lib/Moose/Exception/CannotCalculateNativeType.pm', + 'lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm', + 'lib/Moose/Exception/CannotCallAnAbstractMethod.pm', + 'lib/Moose/Exception/CannotCoerceAWeakRef.pm', + 'lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm', + 'lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm', + 'lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm', + 'lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm', + 'lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm', + 'lib/Moose/Exception/CannotDelegateWithoutIsa.pm', + 'lib/Moose/Exception/CannotFindDelegateMetaclass.pm', + 'lib/Moose/Exception/CannotFindType.pm', + 'lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm', + 'lib/Moose/Exception/CannotFixMetaclassCompatibility.pm', + 'lib/Moose/Exception/CannotGenerateInlineConstraint.pm', + 'lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm', + 'lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm', + 'lib/Moose/Exception/CannotLocatePackageInINC.pm', + 'lib/Moose/Exception/CannotMakeMetaclassCompatible.pm', + 'lib/Moose/Exception/CannotOverrideALocalMethod.pm', + 'lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm', + 'lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm', + 'lib/Moose/Exception/CannotOverrideNoSuperMethod.pm', + 'lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm', + 'lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm', + 'lib/Moose/Exception/CircularReferenceInAlso.pm', + 'lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm', + 'lib/Moose/Exception/ClassDoesTheExcludedRole.pm', + 'lib/Moose/Exception/ClassNamesDoNotMatch.pm', + 'lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm', + 'lib/Moose/Exception/CodeBlockMustBeACodeRef.pm', + 'lib/Moose/Exception/CoercingWithoutCoercions.pm', + 'lib/Moose/Exception/CoercionAlreadyExists.pm', + 'lib/Moose/Exception/CoercionNeedsTypeConstraint.pm', + 'lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm', + 'lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm', + 'lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm', + 'lib/Moose/Exception/CouldNotCreateMethod.pm', + 'lib/Moose/Exception/CouldNotCreateWriter.pm', + 'lib/Moose/Exception/CouldNotEvalConstructor.pm', + 'lib/Moose/Exception/CouldNotEvalDestructor.pm', + 'lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm', + 'lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm', + 'lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm', + 'lib/Moose/Exception/CouldNotParseType.pm', + 'lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm', + 'lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm', + 'lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm', + 'lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm', + 'lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm', + 'lib/Moose/Exception/CreateTakesHashRefOfMethods.pm', + 'lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm', + 'lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm', + 'lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm', + 'lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm', + 'lib/Moose/Exception/DoesRequiresRoleName.pm', + 'lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm', + 'lib/Moose/Exception/EnumValuesMustBeString.pm', + 'lib/Moose/Exception/ExtendsMissingArgs.pm', + 'lib/Moose/Exception/HandlesMustBeAHashRef.pm', + 'lib/Moose/Exception/IllegalInheritedOptions.pm', + 'lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm', + 'lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm', + 'lib/Moose/Exception/InitMetaRequiresClass.pm', + 'lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm', + 'lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm', + 'lib/Moose/Exception/InstanceMustBeABlessedReference.pm', + 'lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm', + 'lib/Moose/Exception/InvalidArgumentToMethod.pm', + 'lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm', + 'lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm', + 'lib/Moose/Exception/InvalidHandleValue.pm', + 'lib/Moose/Exception/InvalidHasProvidedInARole.pm', + 'lib/Moose/Exception/InvalidNameForType.pm', + 'lib/Moose/Exception/InvalidOverloadOperator.pm', + 'lib/Moose/Exception/InvalidRoleApplication.pm', + 'lib/Moose/Exception/InvalidTypeConstraint.pm', + 'lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm', + 'lib/Moose/Exception/InvalidValueForIs.pm', + 'lib/Moose/Exception/IsaDoesNotDoTheRole.pm', + 'lib/Moose/Exception/IsaLacksDoesMethod.pm', + 'lib/Moose/Exception/LazyAttributeNeedsADefault.pm', + 'lib/Moose/Exception/Legacy.pm', + 'lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm', + 'lib/Moose/Exception/MatchActionMustBeACodeRef.pm', + 'lib/Moose/Exception/MessageParameterMustBeCodeRef.pm', + 'lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm', + 'lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm', + 'lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm', + 'lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm', + 'lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm', + 'lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm', + 'lib/Moose/Exception/MetaclassNotLoaded.pm', + 'lib/Moose/Exception/MetaclassTypeIncompatible.pm', + 'lib/Moose/Exception/MethodExpectedAMetaclassObject.pm', + 'lib/Moose/Exception/MethodExpectsFewerArgs.pm', + 'lib/Moose/Exception/MethodExpectsMoreArgs.pm', + 'lib/Moose/Exception/MethodModifierNeedsMethodName.pm', + 'lib/Moose/Exception/MethodNameConflictInRoles.pm', + 'lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm', + 'lib/Moose/Exception/MethodNameNotGiven.pm', + 'lib/Moose/Exception/MustDefineAMethodName.pm', + 'lib/Moose/Exception/MustDefineAnAttributeName.pm', + 'lib/Moose/Exception/MustDefineAnOverloadOperator.pm', + 'lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm', + 'lib/Moose/Exception/MustPassAHashOfOptions.pm', + 'lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm', + 'lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm', + 'lib/Moose/Exception/MustPassEvenNumberOfArguments.pm', + 'lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm', + 'lib/Moose/Exception/MustProvideANameForTheAttribute.pm', + 'lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm', + 'lib/Moose/Exception/MustSpecifyAtleastOneRole.pm', + 'lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm', + 'lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm', + 'lib/Moose/Exception/MustSupplyADelegateToMethod.pm', + 'lib/Moose/Exception/MustSupplyAMetaclass.pm', + 'lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm', + 'lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm', + 'lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm', + 'lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm', + 'lib/Moose/Exception/MustSupplyPackageNameAndName.pm', + 'lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm', + 'lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm', + 'lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm', + 'lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm', + 'lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm', + 'lib/Moose/Exception/NoAttributeFoundInSuperClass.pm', + 'lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm', + 'lib/Moose/Exception/NoCasesMatched.pm', + 'lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm', + 'lib/Moose/Exception/NoDestructorClassSpecified.pm', + 'lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm', + 'lib/Moose/Exception/NoParentGivenToSubtype.pm', + 'lib/Moose/Exception/OnlyInstancesCanBeCloned.pm', + 'lib/Moose/Exception/OperatorIsRequired.pm', + 'lib/Moose/Exception/OverloadConflictInSummation.pm', + 'lib/Moose/Exception/OverloadRequiresAMetaClass.pm', + 'lib/Moose/Exception/OverloadRequiresAMetaMethod.pm', + 'lib/Moose/Exception/OverloadRequiresAMetaOverload.pm', + 'lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm', + 'lib/Moose/Exception/OverloadRequiresAnOperator.pm', + 'lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm', + 'lib/Moose/Exception/OverrideConflictInComposition.pm', + 'lib/Moose/Exception/OverrideConflictInSummation.pm', + 'lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm', + 'lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm', + 'lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm', + 'lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm', + 'lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm', + 'lib/Moose/Exception/RequiredAttributeLacksInitialization.pm', + 'lib/Moose/Exception/RequiredAttributeNeedsADefault.pm', + 'lib/Moose/Exception/RequiredMethodsImportedByClass.pm', + 'lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm', + 'lib/Moose/Exception/Role/Attribute.pm', + 'lib/Moose/Exception/Role/AttributeName.pm', + 'lib/Moose/Exception/Role/Class.pm', + 'lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm', + 'lib/Moose/Exception/Role/Instance.pm', + 'lib/Moose/Exception/Role/InstanceClass.pm', + 'lib/Moose/Exception/Role/InvalidAttributeOptions.pm', + 'lib/Moose/Exception/Role/Method.pm', + 'lib/Moose/Exception/Role/ParamsHash.pm', + 'lib/Moose/Exception/Role/Role.pm', + 'lib/Moose/Exception/Role/RoleForCreate.pm', + 'lib/Moose/Exception/Role/RoleForCreateMOPClass.pm', + 'lib/Moose/Exception/Role/TypeConstraint.pm', + 'lib/Moose/Exception/RoleDoesTheExcludedRole.pm', + 'lib/Moose/Exception/RoleExclusionConflict.pm', + 'lib/Moose/Exception/RoleNameRequired.pm', + 'lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm', + 'lib/Moose/Exception/RolesDoNotSupportAugment.pm', + 'lib/Moose/Exception/RolesDoNotSupportExtends.pm', + 'lib/Moose/Exception/RolesDoNotSupportInner.pm', + 'lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm', + 'lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm', + 'lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm', + 'lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm', + 'lib/Moose/Exception/TriggerMustBeACodeRef.pm', + 'lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm', + 'lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm', + 'lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm', + 'lib/Moose/Exception/UnableToCanonicalizeHandles.pm', + 'lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm', + 'lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm', + 'lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm', + 'lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm', + 'lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm', + 'lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm', + 'lib/Moose/Exception/ValidationFailedForTypeConstraint.pm', + 'lib/Moose/Exception/WrapTakesACodeRefToBless.pm', + 'lib/Moose/Exception/WrongTypeConstraintGiven.pm', + 'lib/Moose/Exporter.pm', + 'lib/Moose/Intro.pod', + 'lib/Moose/Manual.pod', + 'lib/Moose/Manual/Attributes.pod', + 'lib/Moose/Manual/BestPractices.pod', + 'lib/Moose/Manual/Classes.pod', + 'lib/Moose/Manual/Concepts.pod', + 'lib/Moose/Manual/Construction.pod', + 'lib/Moose/Manual/Contributing.pod', + 'lib/Moose/Manual/Delegation.pod', + 'lib/Moose/Manual/Delta.pod', + 'lib/Moose/Manual/Exceptions.pod', + 'lib/Moose/Manual/Exceptions/Manifest.pod', + 'lib/Moose/Manual/FAQ.pod', + 'lib/Moose/Manual/MOP.pod', + 'lib/Moose/Manual/MethodModifiers.pod', + 'lib/Moose/Manual/MooseX.pod', + 'lib/Moose/Manual/Resources.pod', + 'lib/Moose/Manual/Roles.pod', + 'lib/Moose/Manual/Support.pod', + 'lib/Moose/Manual/Types.pod', + 'lib/Moose/Manual/Unsweetened.pod', + 'lib/Moose/Meta/Attribute.pm', + 'lib/Moose/Meta/Attribute/Native.pm', + 'lib/Moose/Meta/Attribute/Native/Trait.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Array.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Bool.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Code.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Counter.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Hash.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Number.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/String.pm', + 'lib/Moose/Meta/Class.pm', + 'lib/Moose/Meta/Class/Immutable/Trait.pm', + 'lib/Moose/Meta/Instance.pm', + 'lib/Moose/Meta/Method.pm', + 'lib/Moose/Meta/Method/Accessor.pm', + 'lib/Moose/Meta/Method/Accessor/Native.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/count.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/first.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/get.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/join.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/map.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/push.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Collection.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/add.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/div.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Reader.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/append.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/chop.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/clear.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/inc.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/length.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/match.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/replace.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/substr.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Writer.pm', + 'lib/Moose/Meta/Method/Augmented.pm', + 'lib/Moose/Meta/Method/Constructor.pm', + 'lib/Moose/Meta/Method/Delegation.pm', + 'lib/Moose/Meta/Method/Destructor.pm', + 'lib/Moose/Meta/Method/Meta.pm', + 'lib/Moose/Meta/Method/Overridden.pm', + 'lib/Moose/Meta/Mixin/AttributeCore.pm', + 'lib/Moose/Meta/Object/Trait.pm', + 'lib/Moose/Meta/Role.pm', + 'lib/Moose/Meta/Role/Application.pm', + 'lib/Moose/Meta/Role/Application/RoleSummation.pm', + 'lib/Moose/Meta/Role/Application/ToClass.pm', + 'lib/Moose/Meta/Role/Application/ToInstance.pm', + 'lib/Moose/Meta/Role/Application/ToRole.pm', + 'lib/Moose/Meta/Role/Attribute.pm', + 'lib/Moose/Meta/Role/Composite.pm', + 'lib/Moose/Meta/Role/Method.pm', + 'lib/Moose/Meta/Role/Method/Conflicting.pm', + 'lib/Moose/Meta/Role/Method/Required.pm', + 'lib/Moose/Meta/TypeCoercion.pm', + 'lib/Moose/Meta/TypeCoercion/Union.pm', + 'lib/Moose/Meta/TypeConstraint.pm', + 'lib/Moose/Meta/TypeConstraint/Class.pm', + 'lib/Moose/Meta/TypeConstraint/DuckType.pm', + 'lib/Moose/Meta/TypeConstraint/Enum.pm', + 'lib/Moose/Meta/TypeConstraint/Parameterizable.pm', + 'lib/Moose/Meta/TypeConstraint/Parameterized.pm', + 'lib/Moose/Meta/TypeConstraint/Registry.pm', + 'lib/Moose/Meta/TypeConstraint/Role.pm', + 'lib/Moose/Meta/TypeConstraint/Union.pm', + 'lib/Moose/Object.pm', + 'lib/Moose/Role.pm', + 'lib/Moose/Spec/Role.pod', + 'lib/Moose/Unsweetened.pod', + 'lib/Moose/Util.pm', + 'lib/Moose/Util/MetaRole.pm', + 'lib/Moose/Util/TypeConstraints.pm', + 'lib/Moose/Util/TypeConstraints/Builtins.pm', + 'lib/Test/Moose.pm', + 'lib/metaclass.pm', + 'lib/oose.pm', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/000_load.t', + 't/attributes/accessor_context.t', + 't/attributes/accessor_inlining.t', + 't/attributes/accessor_override_method.t', + 't/attributes/accessor_overwrite_warning.t', + 't/attributes/attr_dereference_test.t', + 't/attributes/attribute_accessor_generation.t', + 't/attributes/attribute_custom_metaclass.t', + 't/attributes/attribute_delegation.t', + 't/attributes/attribute_does.t', + 't/attributes/attribute_inherited_slot_specs.t', + 't/attributes/attribute_lazy_initializer.t', + 't/attributes/attribute_names.t', + 't/attributes/attribute_reader_generation.t', + 't/attributes/attribute_required.t', + 't/attributes/attribute_traits.t', + 't/attributes/attribute_traits_n_meta.t', + 't/attributes/attribute_traits_parameterized.t', + 't/attributes/attribute_traits_registered.t', + 't/attributes/attribute_triggers.t', + 't/attributes/attribute_type_unions.t', + 't/attributes/attribute_without_any_methods.t', + 't/attributes/attribute_writer_generation.t', + 't/attributes/bad_coerce.t', + 't/attributes/chained_coercion.t', + 't/attributes/clone_weak.t', + 't/attributes/default_class_role_types.t', + 't/attributes/default_undef.t', + 't/attributes/delegation_and_modifiers.t', + 't/attributes/delegation_arg_aliasing.t', + 't/attributes/delegation_target_not_loaded.t', + 't/attributes/illegal_options_for_inheritance.t', + 't/attributes/inherit_lazy_build.t', + 't/attributes/lazy_no_default.t', + 't/attributes/method_generation_rules.t', + 't/attributes/misc_attribute_coerce_lazy.t', + 't/attributes/misc_attribute_tests.t', + 't/attributes/more_attr_delegation.t', + 't/attributes/no_init_arg.t', + 't/attributes/no_slot_access.t', + 't/attributes/non_alpha_attr_names.t', + 't/attributes/numeric_defaults.t', + 't/attributes/trigger_and_coerce.t', + 't/attributes/type_constraint.t', + 't/basics/always_strict_warnings.t', + 't/basics/basic_class_setup.t', + 't/basics/buildargs.t', + 't/basics/buildargs_warning.t', + 't/basics/create.t', + 't/basics/create_anon.t', + 't/basics/deprecations.t', + 't/basics/destruction.t', + 't/basics/error_handling.t', + 't/basics/global-destruction-helper.pl', + 't/basics/global_destruction.t', + 't/basics/import_unimport.t', + 't/basics/inner_and_augment.t', + 't/basics/load_into_main.t', + 't/basics/method_modifier_with_regexp.t', + 't/basics/methods.t', + 't/basics/moose_object_does.t', + 't/basics/moose_respects_type_constraints.t', + 't/basics/override_and_foreign_classes.t', + 't/basics/override_augment_inner_super.t', + 't/basics/rebless.t', + 't/basics/require_superclasses.t', + 't/basics/super_and_override.t', + 't/basics/super_warns_on_args.t', + 't/basics/universal_methods_wrappable.t', + 't/basics/wrapped_method_cxt_propagation.t', + 't/bugs/DEMOLISHALL.t', + 't/bugs/DEMOLISHALL_shortcutted.t', + 't/bugs/DEMOLISH_eats_exceptions.t', + 't/bugs/DEMOLISH_eats_mini.t', + 't/bugs/DEMOLISH_fails_without_metaclass.t', + 't/bugs/Moose_Object_error.t', + 't/bugs/anon_method_metaclass.t', + 't/bugs/application_metarole_compat.t', + 't/bugs/apply_role_to_one_instance_only.t', + 't/bugs/attribute_trait_parameters.t', + 't/bugs/augment_recursion_bug.t', + 't/bugs/coerce_without_coercion.t', + 't/bugs/constructor_object_overload.t', + 't/bugs/create_anon_recursion.t', + 't/bugs/create_anon_role_pass.t', + 't/bugs/delete_sub_stash.t', + 't/bugs/handles_foreign_class_bug.t', + 't/bugs/immutable_metaclass_does_role.t', + 't/bugs/immutable_n_default_x2.t', + 't/bugs/inheriting_from_roles.t', + 't/bugs/inline_reader_bug.t', + 't/bugs/instance_application_role_args.t', + 't/bugs/lazybuild_required_undef.t', + 't/bugs/mark_as_methods_overloading_breakage.t', + 't/bugs/moose_exporter_false_circular_reference_rt_63818.t', + 't/bugs/moose_octal_defaults.t', + 't/bugs/native_trait_handles_bad_value.t', + 't/bugs/overloading_edge_cases.t', + 't/bugs/reader_precedence_bug.t', + 't/bugs/role_caller.t', + 't/bugs/subclass_use_base_bug.t', + 't/bugs/subtype_conflict_bug.t', + 't/bugs/subtype_quote_bug.t', + 't/bugs/super_recursion.t', + 't/bugs/traits_with_exporter.t', + 't/bugs/type_constraint_messages.t', + 't/cmop/ArrayBasedStorage_test.t', + 't/cmop/AttributesWithHistory_test.t', + 't/cmop/BinaryTree_test.t', + 't/cmop/C3MethodDispatchOrder_test.t', + 't/cmop/ClassEncapsulatedAttributes_test.t', + 't/cmop/Class_C3_compatibility.t', + 't/cmop/InsideOutClass_test.t', + 't/cmop/InstanceCountingClass_test.t', + 't/cmop/LazyClass_test.t', + 't/cmop/Perl6Attribute_test.t', + 't/cmop/RT_27329_fix.t', + 't/cmop/RT_39001_fix.t', + 't/cmop/RT_41255.t', + 't/cmop/add_attribute_alternate.t', + 't/cmop/add_method_debugmode.t', + 't/cmop/add_method_modifier.t', + 't/cmop/advanced_methods.t', + 't/cmop/anon_class.t', + 't/cmop/anon_class_create_init.t', + 't/cmop/anon_class_keep_alive.t', + 't/cmop/anon_class_leak.t', + 't/cmop/anon_class_removal.t', + 't/cmop/anon_packages.t', + 't/cmop/attribute.t', + 't/cmop/attribute_duplication.t', + 't/cmop/attribute_errors_and_edge_cases.t', + 't/cmop/attribute_get_read_write.t', + 't/cmop/attribute_initializer.t', + 't/cmop/attribute_introspection.t', + 't/cmop/attribute_non_alpha_name.t', + 't/cmop/attributes.t', + 't/cmop/basic.t', + 't/cmop/before_after_dollar_under.t', + 't/cmop/class_errors_and_edge_cases.t', + 't/cmop/class_is_pristine.t', + 't/cmop/class_precedence_list.t', + 't/cmop/constant_codeinfo.t', + 't/cmop/create_class.t', + 't/cmop/custom_instance.t', + 't/cmop/deprecated.t', + 't/cmop/get_code_info.t', + 't/cmop/immutable_custom_trait.t', + 't/cmop/immutable_metaclass.t', + 't/cmop/immutable_w_constructors.t', + 't/cmop/immutable_w_custom_metaclass.t', + 't/cmop/inline_and_dollar_at.t', + 't/cmop/inline_structor.t', + 't/cmop/insertion_order.t', + 't/cmop/instance.t', + 't/cmop/instance_inline.t', + 't/cmop/instance_metaclass_incompat.t', + 't/cmop/instance_metaclass_incompat_dyn.t', + 't/cmop/lib/ArrayBasedStorage.pm', + 't/cmop/lib/AttributesWithHistory.pm', + 't/cmop/lib/BinaryTree.pm', + 't/cmop/lib/C3MethodDispatchOrder.pm', + 't/cmop/lib/ClassEncapsulatedAttributes.pm', + 't/cmop/lib/InsideOutClass.pm', + 't/cmop/lib/InstanceCountingClass.pm', + 't/cmop/lib/LazyClass.pm', + 't/cmop/lib/MyMetaClass.pm', + 't/cmop/lib/MyMetaClass/Attribute.pm', + 't/cmop/lib/MyMetaClass/Instance.pm', + 't/cmop/lib/MyMetaClass/Method.pm', + 't/cmop/lib/MyMetaClass/Random.pm', + 't/cmop/lib/Perl6Attribute.pm', + 't/cmop/lib/SyntaxError.pm', + 't/cmop/load.t', + 't/cmop/magic.t', + 't/cmop/make_mutable.t', + 't/cmop/meta_method.t', + 't/cmop/meta_package.t', + 't/cmop/meta_package_extension.t', + 't/cmop/metaclass.t', + 't/cmop/metaclass_incompatibility.t', + 't/cmop/metaclass_incompatibility_dyn.t', + 't/cmop/metaclass_inheritance.t', + 't/cmop/metaclass_loads_classes.t', + 't/cmop/metaclass_reinitialize.t', + 't/cmop/method.t', + 't/cmop/method_modifiers.t', + 't/cmop/methods.t', + 't/cmop/modify_parent_method.t', + 't/cmop/new_and_clone_metaclasses.t', + 't/cmop/null_stash.t', + 't/cmop/numeric_defaults.t', + 't/cmop/package_variables.t', + 't/cmop/random_eval_bug.t', + 't/cmop/rebless_instance.t', + 't/cmop/rebless_instance_away.t', + 't/cmop/rebless_overload.t', + 't/cmop/rebless_with_extra_params.t', + 't/cmop/scala_style_mixin_composition.t', + 't/cmop/self_introspection.t', + 't/cmop/subclasses.t', + 't/cmop/subname.t', + 't/cmop/universal_methods.t', + 't/compat/composite_metaroles.t', + 't/compat/extends_nonmoose_that_isa_moose_with_metarole.t', + 't/compat/foreign_inheritence.t', + 't/compat/inc_hash.t', + 't/compat/module_refresh_compat.t', + 't/compat/moose_respects_base.t', + 't/examples/Child_Parent_attr_inherit.t', + 't/examples/example1.t', + 't/examples/example2.t', + 't/examples/example_Moose_POOP.t', + 't/examples/example_Protomoose.t', + 't/examples/example_w_DCS.t', + 't/examples/example_w_TestDeep.t', + 't/examples/record_set_iterator.t', + 't/exceptions/attribute.t', + 't/exceptions/class-mop-attribute.t', + 't/exceptions/class-mop-class-immutable-trait.t', + 't/exceptions/class-mop-class.t', + 't/exceptions/class-mop-method-accessor.t', + 't/exceptions/class-mop-method-constructor.t', + 't/exceptions/class-mop-method-generated.t', + 't/exceptions/class-mop-method-meta.t', + 't/exceptions/class-mop-method-wrapped.t', + 't/exceptions/class-mop-method.t', + 't/exceptions/class-mop-mixin-hasattributes.t', + 't/exceptions/class-mop-mixin-hasmethods.t', + 't/exceptions/class-mop-module.t', + 't/exceptions/class-mop-object.t', + 't/exceptions/class-mop-package.t', + 't/exceptions/class.t', + 't/exceptions/cmop.t', + 't/exceptions/exception-lazyattributeneedsadefault.t', + 't/exceptions/frame-leak.t', + 't/exceptions/meta-role.t', + 't/exceptions/metaclass.t', + 't/exceptions/moose-exporter.t', + 't/exceptions/moose-meta-attribute-native-traits.t', + 't/exceptions/moose-meta-class-immutable-trait.t', + 't/exceptions/moose-meta-method-accessor-native-array.t', + 't/exceptions/moose-meta-method-accessor-native-collection.t', + 't/exceptions/moose-meta-method-accessor-native-grep.t', + 't/exceptions/moose-meta-method-accessor-native-hash-set.t', + 't/exceptions/moose-meta-method-accessor-native-hash.t', + 't/exceptions/moose-meta-method-accessor-native-string-match.t', + 't/exceptions/moose-meta-method-accessor-native-string-replace.t', + 't/exceptions/moose-meta-method-accessor-native-string-substr.t', + 't/exceptions/moose-meta-method-accessor-native.t', + 't/exceptions/moose-meta-method-accessor.t', + 't/exceptions/moose-meta-method-augmented.t', + 't/exceptions/moose-meta-method-constructor.t', + 't/exceptions/moose-meta-method-delegation.t', + 't/exceptions/moose-meta-method-destructor.t', + 't/exceptions/moose-meta-method-overridden.t', + 't/exceptions/moose-meta-role-application-rolesummation.t', + 't/exceptions/moose-meta-role-application-toclass.t', + 't/exceptions/moose-meta-role-application-torole.t', + 't/exceptions/moose-meta-role-application.t', + 't/exceptions/moose-meta-role-attribute.t', + 't/exceptions/moose-meta-role-composite.t', + 't/exceptions/moose-meta-typecoercion-union.t', + 't/exceptions/moose-meta-typecoercion.t', + 't/exceptions/moose-meta-typeconstraint-enum.t', + 't/exceptions/moose-meta-typeconstraint-parameterizable.t', + 't/exceptions/moose-meta-typeconstraint-parameterized.t', + 't/exceptions/moose-meta-typeconstraint-registry.t', + 't/exceptions/moose-meta-typeconstraint.t', + 't/exceptions/moose-role.t', + 't/exceptions/moose-util-metarole.t', + 't/exceptions/moose-util-typeconstraints.t', + 't/exceptions/moose.t', + 't/exceptions/object.t', + 't/exceptions/overload.t', + 't/exceptions/rt-92818.t', + 't/exceptions/rt-94795.t', + 't/exceptions/stringify.t', + 't/exceptions/traits.t', + 't/exceptions/typeconstraints.t', + 't/exceptions/util.t', + 't/immutable/apply_roles_to_immutable.t', + 't/immutable/buildargs.t', + 't/immutable/constructor_is_not_moose.t', + 't/immutable/constructor_is_wrapped.t', + 't/immutable/default_values.t', + 't/immutable/definition_context.t', + 't/immutable/immutable_constructor_error.t', + 't/immutable/immutable_destroy.t', + 't/immutable/immutable_meta_class.t', + 't/immutable/immutable_metaclass_with_traits.t', + 't/immutable/immutable_moose.t', + 't/immutable/immutable_roundtrip.t', + 't/immutable/immutable_trigger_from_constructor.t', + 't/immutable/inline_close_over.t', + 't/immutable/inline_fallbacks.t', + 't/immutable/inlined_constructors_n_types.t', + 't/immutable/multiple_demolish_inline.t', + 't/lib/Bar.pm', + 't/lib/Bar7/Meta/Trait.pm', + 't/lib/Bar7/Meta/Trait2.pm', + 't/lib/Foo.pm', + 't/lib/Moose/Meta/Attribute/Custom/Bar.pm', + 't/lib/Moose/Meta/Attribute/Custom/Foo.pm', + 't/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm', + 't/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm', + 't/lib/MyExporter.pm', + 't/lib/MyMetaclassRole.pm', + 't/lib/MyMooseA.pm', + 't/lib/MyMooseB.pm', + 't/lib/MyMooseObject.pm', + 't/lib/NoInlineAttribute.pm', + 't/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm', + 't/lib/Overloading/ClassWithCombiningRole.pm', + 't/lib/Overloading/ClassWithOneRole.pm', + 't/lib/Overloading/CombiningClass.pm', + 't/lib/Overloading/CombiningRole.pm', + 't/lib/Overloading/RoleConsumesOverloads.pm', + 't/lib/Overloading/RoleWithOverloads.pm', + 't/lib/Overloading/RoleWithoutOverloads.pm', + 't/lib/OverloadingTests.pm', + 't/lib/Real/Package.pm', + 't/lib/Role/BreakOnLoad.pm', + 't/lib/Role/Child.pm', + 't/lib/Role/Interface.pm', + 't/lib/Role/Parent.pm', + 't/metaclasses/create_anon_with_required_attr.t', + 't/metaclasses/custom_attr_meta_as_role.t', + 't/metaclasses/custom_attr_meta_with_roles.t', + 't/metaclasses/easy_init_meta.t', + 't/metaclasses/export_with_prototype.t', + 't/metaclasses/exporter_also_with_trait.t', + 't/metaclasses/exporter_meta_lookup.t', + 't/metaclasses/exporter_sub_names.t', + 't/metaclasses/goto_moose_import.t', + 't/metaclasses/immutable_metaclass_compat_bug.t', + 't/metaclasses/meta_name.t', + 't/metaclasses/metaclass_compat.t', + 't/metaclasses/metaclass_compat_no_fixing_bug.t', + 't/metaclasses/metaclass_compat_role_conflicts.t', + 't/metaclasses/metaclass_parameterized_traits.t', + 't/metaclasses/metaclass_traits.t', + 't/metaclasses/metarole.t', + 't/metaclasses/metarole_combination.t', + 't/metaclasses/metarole_on_anon.t', + 't/metaclasses/metarole_w_metaclass_pm.t', + 't/metaclasses/metaroles_of_metaroles.t', + 't/metaclasses/moose_exporter.t', + 't/metaclasses/moose_exporter_trait_aliases.t', + 't/metaclasses/moose_for_meta.t', + 't/metaclasses/moose_nonmoose_metatrait_init_order.t', + 't/metaclasses/moose_nonmoose_moose_chain_init_meta.t', + 't/metaclasses/moose_w_metaclass.t', + 't/metaclasses/new_metaclass.t', + 't/metaclasses/new_object_BUILD.t', + 't/metaclasses/overloading.t', + 't/metaclasses/reinitialize.t', + 't/metaclasses/use_base_of_moose.t', + 't/moose_util/apply_roles.t', + 't/moose_util/create_alias.t', + 't/moose_util/ensure_all_roles.t', + 't/moose_util/method_mod_args.t', + 't/moose_util/moose_util.t', + 't/moose_util/moose_util_does_role.t', + 't/moose_util/moose_util_search_class_by_role.t', + 't/moose_util/resolve_alias.t', + 't/moose_util/with_traits.t', + 't/native_traits/array_coerce.t', + 't/native_traits/array_from_role.t', + 't/native_traits/array_subtypes.t', + 't/native_traits/array_trigger.t', + 't/native_traits/collection_with_roles.t', + 't/native_traits/custom_instance.t', + 't/native_traits/hash_coerce.t', + 't/native_traits/hash_subtypes.t', + 't/native_traits/hash_trigger.t', + 't/native_traits/remove_attribute.t', + 't/native_traits/shallow_clone.t', + 't/native_traits/trait_array.t', + 't/native_traits/trait_bool.t', + 't/native_traits/trait_code.t', + 't/native_traits/trait_counter.t', + 't/native_traits/trait_hash.t', + 't/native_traits/trait_number.t', + 't/native_traits/trait_string.t', + 't/recipes/basics_bankaccount_methodmodifiersandsubclassing.t', + 't/recipes/basics_binarytree_attributefeatures.t', + 't/recipes/basics_company_subtypes.t', + 't/recipes/basics_datetime_extendingnonmooseparent.t', + 't/recipes/basics_document_augmentandinner.t', + 't/recipes/basics_genome_overloadingsubtypesandcoercion.t', + 't/recipes/basics_http_subtypesandcoercion.t', + 't/recipes/basics_point_attributesandsubclassing.t', + 't/recipes/extending_debugging_baseclassrole.t', + 't/recipes/extending_mooseish_moosesugar.t', + 't/recipes/legacy_debugging_baseclassreplacement.t', + 't/recipes/legacy_labeled_attributemetaclass.t', + 't/recipes/meta_globref_instancemetaclass.t', + 't/recipes/meta_labeled_attributetrait.t', + 't/recipes/meta_privateorpublic_methodmetaclass.t', + 't/recipes/meta_table_metaclasstrait.t', + 't/recipes/roles_applicationtoinstance.t', + 't/recipes/roles_comparable_codereuse.t', + 't/recipes/roles_restartable_advancedcomposition.t', + 't/roles/anonymous_roles.t', + 't/roles/application_toclass.t', + 't/roles/apply_role.t', + 't/roles/build.t', + 't/roles/conflict_many_methods.t', + 't/roles/create_role.t', + 't/roles/create_role_subclass.t', + 't/roles/empty_method_modifiers_meta_bug.t', + 't/roles/extending_role_attrs.t', + 't/roles/free_anonymous_roles.t', + 't/roles/imported_required_method.t', + 't/roles/meta_role.t', + 't/roles/method_aliasing_in_composition.t', + 't/roles/method_exclusion_in_composition.t', + 't/roles/method_modifiers.t', + 't/roles/methods.t', + 't/roles/more_alias_and_exclude.t', + 't/roles/more_role_edge_cases.t', + 't/roles/new_meta_role.t', + 't/roles/overloading_combine_to_class.t', + 't/roles/overloading_combine_to_instance.t', + 't/roles/overloading_combine_to_role.t', + 't/roles/overloading_composition_errors.t', + 't/roles/overloading_remove_attributes_bug.t', + 't/roles/overloading_to_class.t', + 't/roles/overloading_to_instance.t', + 't/roles/overloading_to_role.t', + 't/roles/overriding.t', + 't/roles/reinitialize_anon_role.t', + 't/roles/role.t', + 't/roles/role_attr_application.t', + 't/roles/role_attribute_conflict.t', + 't/roles/role_attrs.t', + 't/roles/role_compose_requires.t', + 't/roles/role_composite.t', + 't/roles/role_composite_exclusion.t', + 't/roles/role_composition_attributes.t', + 't/roles/role_composition_conflict_detection.t', + 't/roles/role_composition_errors.t', + 't/roles/role_composition_method_mods.t', + 't/roles/role_composition_methods.t', + 't/roles/role_composition_override.t', + 't/roles/role_composition_req_methods.t', + 't/roles/role_conflict_detection.t', + 't/roles/role_conflict_edge_cases.t', + 't/roles/role_consumers.t', + 't/roles/role_exclusion.t', + 't/roles/role_exclusion_and_alias_bug.t', + 't/roles/role_for_combination.t', + 't/roles/roles_and_method_cloning.t', + 't/roles/roles_and_req_method_edge_cases.t', + 't/roles/roles_applied_in_create.t', + 't/roles/run_time_role_composition.t', + 't/roles/runtime_roles_and_attrs.t', + 't/roles/runtime_roles_and_nonmoose.t', + 't/roles/runtime_roles_w_params.t', + 't/roles/use_base_does.t', + 't/test_moose/test_moose.t', + 't/test_moose/test_moose_does_ok.t', + 't/test_moose/test_moose_has_attribute_ok.t', + 't/test_moose/test_moose_meta_ok.t', + 't/test_moose/with_immutable.t', + 't/todo_tests/exception_reflects_failed_constraint.t', + 't/todo_tests/immutable_n_around.t', + 't/todo_tests/moose_and_threads.t', + 't/todo_tests/replacing_super_methods.t', + 't/todo_tests/required_role_accessors.t', + 't/todo_tests/role_attr_methods_original_package.t', + 't/todo_tests/role_insertion_order.t', + 't/todo_tests/various_role_features.t', + 't/todo_tests/wrong-inner.t', + 't/type_constraints/advanced_type_creation.t', + 't/type_constraints/class_subtypes.t', + 't/type_constraints/class_type_constraint.t', + 't/type_constraints/coerced_parameterized_types.t', + 't/type_constraints/container_type_coercion.t', + 't/type_constraints/container_type_constraint.t', + 't/type_constraints/custom_parameterized_types.t', + 't/type_constraints/custom_type_errors.t', + 't/type_constraints/define_type_twice_throws.t', + 't/type_constraints/duck_type_handles.t', + 't/type_constraints/duck_types.t', + 't/type_constraints/enum.t', + 't/type_constraints/inlining.t', + 't/type_constraints/match_type_operator.t', + 't/type_constraints/maybe_type_constraint.t', + 't/type_constraints/misc_type_tests.t', + 't/type_constraints/name_conflicts.t', + 't/type_constraints/normalize_type_name.t', + 't/type_constraints/parameterize_from.t', + 't/type_constraints/role_type_constraint.t', + 't/type_constraints/subtype_auto_vivify_parent.t', + 't/type_constraints/subtyping_parameterized_types.t', + 't/type_constraints/subtyping_union_types.t', + 't/type_constraints/throw_error.t', + 't/type_constraints/type_coersion_on_lazy_attributes.t', + 't/type_constraints/type_names.t', + 't/type_constraints/type_notation_parser.t', + 't/type_constraints/types_and_undef.t', + 't/type_constraints/union_is_a_type_of.t', + 't/type_constraints/union_types.t', + 't/type_constraints/union_types_and_coercions.t', + 't/type_constraints/util_find_type_constraint.t', + 't/type_constraints/util_more_type_coercion.t', + 't/type_constraints/util_std_type_constraints.t', + 't/type_constraints/util_type_coercion.t', + 't/type_constraints/util_type_constraints.t', + 't/type_constraints/util_type_constraints_export.t', + 't/type_constraints/util_type_reloading.t', + 't/type_constraints/with-specio.t', + 't/zzz-check-breaks.t' +); + +eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files; +done_testing; diff --git a/xt/author/memory_leaks.t b/xt/author/memory_leaks.t new file mode 100644 index 0000000..da68698 --- /dev/null +++ b/xt/author/memory_leaks.t @@ -0,0 +1,239 @@ +use strict; +use warnings; + +use Test::More; +BEGIN { + plan skip_all => 'Leak tests fail under perl 5.21.[6-9]' + if $] >= '5.021006' and $] <= '5.021011'; + plan skip_all => 'Leak tests fail under Devel::Cover' if $INC{'Devel/Cover.pm'}; +} + +use Test::LeakTrace; +use Test::Memory::Cycle; +use Moose (); +use Moose::Util qw( apply_all_roles ); +use Moose::Util::TypeConstraints; + +{ + package MyRole; + use Moose::Role; + sub myname { "I'm a role" } +} + +{ + package Fake::DateTime; + use Moose; + + has 'string_repr' => ( is => 'ro' ); + + package Mortgage; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Fake::DateTime' => from 'Str' => + via { Fake::DateTime->new( string_repr => $_ ) }; + + has 'closing_date' => ( + is => 'rw', + isa => 'Fake::DateTime', + coerce => 1, + trigger => sub { + my ( $self, $val ) = @_; + ::pass('... trigger is being called'); + ::isa_ok( $self->closing_date, 'Fake::DateTime' ); + ::isa_ok( $val, 'Fake::DateTime' ); + } + ); +} + +{ + package Man; + use Moose; + + my @actions; + + sub live { + push @actions, 'live'; + } + + sub create { + push @actions, 'create'; + } + + sub breathe { + push @actions, 'breathe'; + } + + package Earth; + use Moose; + use Moose::Util::TypeConstraints; + + has man => ( + isa => 'Man', + handles => [qw( live create breathe )], + ); +} + + +{ + local $TODO = 'anonymous classes leak on 5.8' if $] < 5.010; + no_leaks_ok( + sub { + Moose::Meta::Class->create_anon_class->new_object; + }, + 'anonymous class with no roles is leak-free' + ); +} + +no_leaks_ok( + sub { + Moose::Meta::Role->initialize('MyRole2'); + }, + 'Moose::Meta::Role->initialize is leak-free' +); + +no_leaks_ok( + sub { + Moose::Meta::Class->create('MyClass2')->new_object; + }, + 'creating named class is leak-free' +); + +{ + local $TODO + = 'role application leaks because we end up applying the role more than once to the meta object'; + no_leaks_ok( + sub { + Moose::Meta::Class->create( 'MyClass', roles => ['MyRole'] ); + }, + 'named class with roles is leak-free' + ); + + no_leaks_ok( + sub { + Moose::Meta::Role->create( 'MyRole2', roles => ['MyRole'] ); + }, + 'named role with roles is leak-free' + ); +} + +no_leaks_ok( + sub { + my $object = Moose::Meta::Class->create('MyClass2')->new_object; + apply_all_roles( $object, 'MyRole' ); + }, + 'applying role to an instance is leak-free' +); + +no_leaks_ok( + sub { + Moose::Meta::Role->create_anon_role; + }, + 'anonymous role is leak-free' +); + +{ + # fixing this leak currently triggers a bug in Carp + # we can un-TODO once that fix goes in allowing the leak + # in Eval::Closure to be fixed + local $TODO = 'Eval::Closure leaks a bit at the moment'; + no_leaks_ok( + sub { + my $meta = Moose::Meta::Class->create_anon_class; + $meta->make_immutable; + }, + 'making an anon class immutable is leak-free' + ); +} + +{ + my $meta3 = Moose::Meta::Class->create('MyClass3'); + memory_cycle_ok( $meta3, 'named metaclass object is cycle-free' ); + memory_cycle_ok( $meta3->new_object, 'MyClass3 object is cycle-free' ); + + my $anon_class = Moose::Meta::Class->create_anon_class; + memory_cycle_ok($anon_class, 'anon metaclass object is cycle-free' ); + memory_cycle_ok( $anon_class->new_object, 'object from anon metaclass is cycle-free' ); + + $anon_class->make_immutable; + memory_cycle_ok($anon_class, 'immutable anon metaclass object is cycle-free' ); + memory_cycle_ok( $anon_class->new_object, 'object from immutable anon metaclass is cycle-free' ); + + my $anon_role = Moose::Meta::Role->create_anon_role; + memory_cycle_ok($anon_role, 'anon role meta object is cycle-free' ); +} + +{ + my $Str = find_type_constraint('Str'); + my $Undef = find_type_constraint('Undef'); + my $Str_or_Undef = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str, $Undef ] ); + memory_cycle_ok($Str_or_Undef, 'union types do not leak'); +} + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + $mtg->closing_date; + Mortgage->meta->make_immutable; + + memory_cycle_ok($mtg->meta, 'meta (triggers/coerce) is cycle-free'); +} + +{ + local $TODO = 'meta cycles exist at the moment'; + memory_cycle_ok(Earth->new->meta, 'meta (handles) is cycle-free'); + memory_cycle_ok(Earth->meta, 'meta (class) is cycle-free'); +} + +{ + my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } + )); + + my $Point3D = Class::MOP::Class->create('Point3D' => ( + version => '0.01', + superclasses => [ 'Point' ], + attributes => [ + Class::MOP::Attribute->new('z' => ( + default => 123 + )), + ], + methods => { + 'clear' => sub { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } + } + )); + + local $TODO = 'CMOP cycles exist at the moment'; + memory_cycle_ok($Point3D, 'Point3D is cycle-free'); + memory_cycle_ok($Point, 'Point is cycle-free'); + memory_cycle_ok($Point3D->meta, 'Point3D meta is cycle-free'); + memory_cycle_ok($Point->meta, 'Point meta is cycle-free'); +} + +done_testing; diff --git a/xt/author/no-tabs.t b/xt/author/no-tabs.t new file mode 100644 index 0000000..7df0dfc --- /dev/null +++ b/xt/author/no-tabs.t @@ -0,0 +1,969 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15 + +use Test::More 0.88; +use Test::NoTabs; + +my @files = ( + 'bin/moose-outdated', + 'lib/Class/MOP.pm', + 'lib/Class/MOP/Attribute.pm', + 'lib/Class/MOP/Class.pm', + 'lib/Class/MOP/Class/Immutable/Trait.pm', + 'lib/Class/MOP/Deprecated.pm', + 'lib/Class/MOP/Instance.pm', + 'lib/Class/MOP/Method.pm', + 'lib/Class/MOP/Method/Accessor.pm', + 'lib/Class/MOP/Method/Constructor.pm', + 'lib/Class/MOP/Method/Generated.pm', + 'lib/Class/MOP/Method/Inlined.pm', + 'lib/Class/MOP/Method/Meta.pm', + 'lib/Class/MOP/Method/Wrapped.pm', + 'lib/Class/MOP/MiniTrait.pm', + 'lib/Class/MOP/Mixin.pm', + 'lib/Class/MOP/Mixin/AttributeCore.pm', + 'lib/Class/MOP/Mixin/HasAttributes.pm', + 'lib/Class/MOP/Mixin/HasMethods.pm', + 'lib/Class/MOP/Mixin/HasOverloads.pm', + 'lib/Class/MOP/Module.pm', + 'lib/Class/MOP/Object.pm', + 'lib/Class/MOP/Overload.pm', + 'lib/Class/MOP/Package.pm', + 'lib/Moose.pm', + 'lib/Moose/Conflicts.pm', + 'lib/Moose/Cookbook.pod', + 'lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod', + 'lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod', + 'lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod', + 'lib/Moose/Cookbook/Basics/Company_Subtypes.pod', + 'lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod', + 'lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod', + 'lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod', + 'lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod', + 'lib/Moose/Cookbook/Basics/Immutable.pod', + 'lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod', + 'lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod', + 'lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod', + 'lib/Moose/Cookbook/Extending/ExtensionOverview.pod', + 'lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod', + 'lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod', + 'lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod', + 'lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod', + 'lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod', + 'lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod', + 'lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod', + 'lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod', + 'lib/Moose/Cookbook/Meta/WhyMeta.pod', + 'lib/Moose/Cookbook/Roles/ApplicationToInstance.pod', + 'lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod', + 'lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod', + 'lib/Moose/Cookbook/Snack/Keywords.pod', + 'lib/Moose/Cookbook/Snack/Types.pod', + 'lib/Moose/Cookbook/Style.pod', + 'lib/Moose/Deprecated.pm', + 'lib/Moose/Exception.pm', + 'lib/Moose/Exception/AccessorMustReadWrite.pm', + 'lib/Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm', + 'lib/Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm', + 'lib/Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm', + 'lib/Moose/Exception/ApplyTakesABlessedInstance.pm', + 'lib/Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm', + 'lib/Moose/Exception/AttributeConflictInRoles.pm', + 'lib/Moose/Exception/AttributeConflictInSummation.pm', + 'lib/Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm', + 'lib/Moose/Exception/AttributeIsRequired.pm', + 'lib/Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm', + 'lib/Moose/Exception/AttributeNamesDoNotMatch.pm', + 'lib/Moose/Exception/AttributeValueIsNotAnObject.pm', + 'lib/Moose/Exception/AttributeValueIsNotDefined.pm', + 'lib/Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm', + 'lib/Moose/Exception/BadOptionFormat.pm', + 'lib/Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm', + 'lib/Moose/Exception/BuilderDoesNotExist.pm', + 'lib/Moose/Exception/BuilderMethodNotSupportedForAttribute.pm', + 'lib/Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm', + 'lib/Moose/Exception/BuilderMustBeAMethodName.pm', + 'lib/Moose/Exception/CallingMethodOnAnImmutableInstance.pm', + 'lib/Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm', + 'lib/Moose/Exception/CanExtendOnlyClasses.pm', + 'lib/Moose/Exception/CanOnlyConsumeRole.pm', + 'lib/Moose/Exception/CanOnlyWrapBlessedCode.pm', + 'lib/Moose/Exception/CanReblessOnlyIntoASubclass.pm', + 'lib/Moose/Exception/CanReblessOnlyIntoASuperclass.pm', + 'lib/Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm', + 'lib/Moose/Exception/CannotAddAsAnAttributeToARole.pm', + 'lib/Moose/Exception/CannotApplyBaseClassRolesToRole.pm', + 'lib/Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm', + 'lib/Moose/Exception/CannotAugmentIfLocalMethodPresent.pm', + 'lib/Moose/Exception/CannotAugmentNoSuperMethod.pm', + 'lib/Moose/Exception/CannotAutoDerefWithoutIsa.pm', + 'lib/Moose/Exception/CannotAutoDereferenceTypeConstraint.pm', + 'lib/Moose/Exception/CannotCalculateNativeType.pm', + 'lib/Moose/Exception/CannotCallAnAbstractBaseMethod.pm', + 'lib/Moose/Exception/CannotCallAnAbstractMethod.pm', + 'lib/Moose/Exception/CannotCoerceAWeakRef.pm', + 'lib/Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm', + 'lib/Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm', + 'lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm', + 'lib/Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm', + 'lib/Moose/Exception/CannotDelegateLocalMethodIsPresent.pm', + 'lib/Moose/Exception/CannotDelegateWithoutIsa.pm', + 'lib/Moose/Exception/CannotFindDelegateMetaclass.pm', + 'lib/Moose/Exception/CannotFindType.pm', + 'lib/Moose/Exception/CannotFindTypeGivenToMatchOnType.pm', + 'lib/Moose/Exception/CannotFixMetaclassCompatibility.pm', + 'lib/Moose/Exception/CannotGenerateInlineConstraint.pm', + 'lib/Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm', + 'lib/Moose/Exception/CannotInlineTypeConstraintCheck.pm', + 'lib/Moose/Exception/CannotLocatePackageInINC.pm', + 'lib/Moose/Exception/CannotMakeMetaclassCompatible.pm', + 'lib/Moose/Exception/CannotOverrideALocalMethod.pm', + 'lib/Moose/Exception/CannotOverrideBodyOfMetaMethods.pm', + 'lib/Moose/Exception/CannotOverrideLocalMethodIsPresent.pm', + 'lib/Moose/Exception/CannotOverrideNoSuperMethod.pm', + 'lib/Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm', + 'lib/Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm', + 'lib/Moose/Exception/CircularReferenceInAlso.pm', + 'lib/Moose/Exception/ClassDoesNotHaveInitMeta.pm', + 'lib/Moose/Exception/ClassDoesTheExcludedRole.pm', + 'lib/Moose/Exception/ClassNamesDoNotMatch.pm', + 'lib/Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm', + 'lib/Moose/Exception/CodeBlockMustBeACodeRef.pm', + 'lib/Moose/Exception/CoercingWithoutCoercions.pm', + 'lib/Moose/Exception/CoercionAlreadyExists.pm', + 'lib/Moose/Exception/CoercionNeedsTypeConstraint.pm', + 'lib/Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm', + 'lib/Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm', + 'lib/Moose/Exception/ConstructClassInstanceTakesPackageName.pm', + 'lib/Moose/Exception/CouldNotCreateMethod.pm', + 'lib/Moose/Exception/CouldNotCreateWriter.pm', + 'lib/Moose/Exception/CouldNotEvalConstructor.pm', + 'lib/Moose/Exception/CouldNotEvalDestructor.pm', + 'lib/Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm', + 'lib/Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm', + 'lib/Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm', + 'lib/Moose/Exception/CouldNotParseType.pm', + 'lib/Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm', + 'lib/Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm', + 'lib/Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm', + 'lib/Moose/Exception/CreateTakesArrayRefOfRoles.pm', + 'lib/Moose/Exception/CreateTakesHashRefOfAttributes.pm', + 'lib/Moose/Exception/CreateTakesHashRefOfMethods.pm', + 'lib/Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm', + 'lib/Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm', + 'lib/Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm', + 'lib/Moose/Exception/DelegationToATypeWhichIsNotAClass.pm', + 'lib/Moose/Exception/DoesRequiresRoleName.pm', + 'lib/Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm', + 'lib/Moose/Exception/EnumValuesMustBeString.pm', + 'lib/Moose/Exception/ExtendsMissingArgs.pm', + 'lib/Moose/Exception/HandlesMustBeAHashRef.pm', + 'lib/Moose/Exception/IllegalInheritedOptions.pm', + 'lib/Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm', + 'lib/Moose/Exception/IncompatibleMetaclassOfSuperclass.pm', + 'lib/Moose/Exception/InitMetaRequiresClass.pm', + 'lib/Moose/Exception/InitializeTakesUnBlessedPackageName.pm', + 'lib/Moose/Exception/InstanceBlessedIntoWrongClass.pm', + 'lib/Moose/Exception/InstanceMustBeABlessedReference.pm', + 'lib/Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm', + 'lib/Moose/Exception/InvalidArgumentToMethod.pm', + 'lib/Moose/Exception/InvalidArgumentsToTraitAliases.pm', + 'lib/Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm', + 'lib/Moose/Exception/InvalidHandleValue.pm', + 'lib/Moose/Exception/InvalidHasProvidedInARole.pm', + 'lib/Moose/Exception/InvalidNameForType.pm', + 'lib/Moose/Exception/InvalidOverloadOperator.pm', + 'lib/Moose/Exception/InvalidRoleApplication.pm', + 'lib/Moose/Exception/InvalidTypeConstraint.pm', + 'lib/Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm', + 'lib/Moose/Exception/InvalidValueForIs.pm', + 'lib/Moose/Exception/IsaDoesNotDoTheRole.pm', + 'lib/Moose/Exception/IsaLacksDoesMethod.pm', + 'lib/Moose/Exception/LazyAttributeNeedsADefault.pm', + 'lib/Moose/Exception/Legacy.pm', + 'lib/Moose/Exception/MOPAttributeNewNeedsAttributeName.pm', + 'lib/Moose/Exception/MatchActionMustBeACodeRef.pm', + 'lib/Moose/Exception/MessageParameterMustBeCodeRef.pm', + 'lib/Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm', + 'lib/Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm', + 'lib/Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm', + 'lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm', + 'lib/Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm', + 'lib/Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm', + 'lib/Moose/Exception/MetaclassNotLoaded.pm', + 'lib/Moose/Exception/MetaclassTypeIncompatible.pm', + 'lib/Moose/Exception/MethodExpectedAMetaclassObject.pm', + 'lib/Moose/Exception/MethodExpectsFewerArgs.pm', + 'lib/Moose/Exception/MethodExpectsMoreArgs.pm', + 'lib/Moose/Exception/MethodModifierNeedsMethodName.pm', + 'lib/Moose/Exception/MethodNameConflictInRoles.pm', + 'lib/Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm', + 'lib/Moose/Exception/MethodNameNotGiven.pm', + 'lib/Moose/Exception/MustDefineAMethodName.pm', + 'lib/Moose/Exception/MustDefineAnAttributeName.pm', + 'lib/Moose/Exception/MustDefineAnOverloadOperator.pm', + 'lib/Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm', + 'lib/Moose/Exception/MustPassAHashOfOptions.pm', + 'lib/Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm', + 'lib/Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm', + 'lib/Moose/Exception/MustPassEvenNumberOfArguments.pm', + 'lib/Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm', + 'lib/Moose/Exception/MustProvideANameForTheAttribute.pm', + 'lib/Moose/Exception/MustSpecifyAtleastOneMethod.pm', + 'lib/Moose/Exception/MustSpecifyAtleastOneRole.pm', + 'lib/Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm', + 'lib/Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm', + 'lib/Moose/Exception/MustSupplyADelegateToMethod.pm', + 'lib/Moose/Exception/MustSupplyAMetaclass.pm', + 'lib/Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm', + 'lib/Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm', + 'lib/Moose/Exception/MustSupplyAnAttributeToConstructWith.pm', + 'lib/Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm', + 'lib/Moose/Exception/MustSupplyPackageNameAndName.pm', + 'lib/Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm', + 'lib/Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm', + 'lib/Moose/Exception/NeitherClassNorClassNameIsGiven.pm', + 'lib/Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm', + 'lib/Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm', + 'lib/Moose/Exception/NoAttributeFoundInSuperClass.pm', + 'lib/Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm', + 'lib/Moose/Exception/NoCasesMatched.pm', + 'lib/Moose/Exception/NoConstraintCheckForTypeConstraint.pm', + 'lib/Moose/Exception/NoDestructorClassSpecified.pm', + 'lib/Moose/Exception/NoImmutableTraitSpecifiedForClass.pm', + 'lib/Moose/Exception/NoParentGivenToSubtype.pm', + 'lib/Moose/Exception/OnlyInstancesCanBeCloned.pm', + 'lib/Moose/Exception/OperatorIsRequired.pm', + 'lib/Moose/Exception/OverloadConflictInSummation.pm', + 'lib/Moose/Exception/OverloadRequiresAMetaClass.pm', + 'lib/Moose/Exception/OverloadRequiresAMetaMethod.pm', + 'lib/Moose/Exception/OverloadRequiresAMetaOverload.pm', + 'lib/Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm', + 'lib/Moose/Exception/OverloadRequiresAnOperator.pm', + 'lib/Moose/Exception/OverloadRequiresNamesForCoderef.pm', + 'lib/Moose/Exception/OverrideConflictInComposition.pm', + 'lib/Moose/Exception/OverrideConflictInSummation.pm', + 'lib/Moose/Exception/PackageDoesNotUseMooseExporter.pm', + 'lib/Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm', + 'lib/Moose/Exception/PackagesAndModulesAreNotCachable.pm', + 'lib/Moose/Exception/ParameterIsNotSubtypeOfParent.pm', + 'lib/Moose/Exception/ReferencesAreNotAllowedAsDefault.pm', + 'lib/Moose/Exception/RequiredAttributeLacksInitialization.pm', + 'lib/Moose/Exception/RequiredAttributeNeedsADefault.pm', + 'lib/Moose/Exception/RequiredMethodsImportedByClass.pm', + 'lib/Moose/Exception/RequiredMethodsNotImplementedByClass.pm', + 'lib/Moose/Exception/Role/Attribute.pm', + 'lib/Moose/Exception/Role/AttributeName.pm', + 'lib/Moose/Exception/Role/Class.pm', + 'lib/Moose/Exception/Role/EitherAttributeOrAttributeName.pm', + 'lib/Moose/Exception/Role/Instance.pm', + 'lib/Moose/Exception/Role/InstanceClass.pm', + 'lib/Moose/Exception/Role/InvalidAttributeOptions.pm', + 'lib/Moose/Exception/Role/Method.pm', + 'lib/Moose/Exception/Role/ParamsHash.pm', + 'lib/Moose/Exception/Role/Role.pm', + 'lib/Moose/Exception/Role/RoleForCreate.pm', + 'lib/Moose/Exception/Role/RoleForCreateMOPClass.pm', + 'lib/Moose/Exception/Role/TypeConstraint.pm', + 'lib/Moose/Exception/RoleDoesTheExcludedRole.pm', + 'lib/Moose/Exception/RoleExclusionConflict.pm', + 'lib/Moose/Exception/RoleNameRequired.pm', + 'lib/Moose/Exception/RoleNameRequiredForMooseMetaRole.pm', + 'lib/Moose/Exception/RolesDoNotSupportAugment.pm', + 'lib/Moose/Exception/RolesDoNotSupportExtends.pm', + 'lib/Moose/Exception/RolesDoNotSupportInner.pm', + 'lib/Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm', + 'lib/Moose/Exception/RolesInCreateTakesAnArrayRef.pm', + 'lib/Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm', + 'lib/Moose/Exception/SingleParamsToNewMustBeHashRef.pm', + 'lib/Moose/Exception/TriggerMustBeACodeRef.pm', + 'lib/Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm', + 'lib/Moose/Exception/TypeConstraintIsAlreadyCreated.pm', + 'lib/Moose/Exception/TypeParameterMustBeMooseMetaType.pm', + 'lib/Moose/Exception/UnableToCanonicalizeHandles.pm', + 'lib/Moose/Exception/UnableToCanonicalizeNonRolePackage.pm', + 'lib/Moose/Exception/UnableToRecognizeDelegateMetaclass.pm', + 'lib/Moose/Exception/UndefinedHashKeysPassedToMethod.pm', + 'lib/Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm', + 'lib/Moose/Exception/UnionTakesAtleastTwoTypeNames.pm', + 'lib/Moose/Exception/ValidationFailedForInlineTypeConstraint.pm', + 'lib/Moose/Exception/ValidationFailedForTypeConstraint.pm', + 'lib/Moose/Exception/WrapTakesACodeRefToBless.pm', + 'lib/Moose/Exception/WrongTypeConstraintGiven.pm', + 'lib/Moose/Exporter.pm', + 'lib/Moose/Intro.pod', + 'lib/Moose/Manual.pod', + 'lib/Moose/Manual/Attributes.pod', + 'lib/Moose/Manual/BestPractices.pod', + 'lib/Moose/Manual/Classes.pod', + 'lib/Moose/Manual/Concepts.pod', + 'lib/Moose/Manual/Construction.pod', + 'lib/Moose/Manual/Contributing.pod', + 'lib/Moose/Manual/Delegation.pod', + 'lib/Moose/Manual/Delta.pod', + 'lib/Moose/Manual/Exceptions.pod', + 'lib/Moose/Manual/Exceptions/Manifest.pod', + 'lib/Moose/Manual/FAQ.pod', + 'lib/Moose/Manual/MOP.pod', + 'lib/Moose/Manual/MethodModifiers.pod', + 'lib/Moose/Manual/MooseX.pod', + 'lib/Moose/Manual/Resources.pod', + 'lib/Moose/Manual/Roles.pod', + 'lib/Moose/Manual/Support.pod', + 'lib/Moose/Manual/Types.pod', + 'lib/Moose/Manual/Unsweetened.pod', + 'lib/Moose/Meta/Attribute.pm', + 'lib/Moose/Meta/Attribute/Native.pm', + 'lib/Moose/Meta/Attribute/Native/Trait.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Array.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Bool.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Code.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Counter.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Hash.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/Number.pm', + 'lib/Moose/Meta/Attribute/Native/Trait/String.pm', + 'lib/Moose/Meta/Class.pm', + 'lib/Moose/Meta/Class/Immutable/Trait.pm', + 'lib/Moose/Meta/Instance.pm', + 'lib/Moose/Meta/Method.pm', + 'lib/Moose/Meta/Method/Accessor.pm', + 'lib/Moose/Meta/Method/Accessor/Native.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/count.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/first.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/get.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/join.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/map.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/push.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Collection.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/add.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/div.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/set.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Reader.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/append.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/chop.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/clear.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/inc.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/length.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/match.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/replace.pm', + 'lib/Moose/Meta/Method/Accessor/Native/String/substr.pm', + 'lib/Moose/Meta/Method/Accessor/Native/Writer.pm', + 'lib/Moose/Meta/Method/Augmented.pm', + 'lib/Moose/Meta/Method/Constructor.pm', + 'lib/Moose/Meta/Method/Delegation.pm', + 'lib/Moose/Meta/Method/Destructor.pm', + 'lib/Moose/Meta/Method/Meta.pm', + 'lib/Moose/Meta/Method/Overridden.pm', + 'lib/Moose/Meta/Mixin/AttributeCore.pm', + 'lib/Moose/Meta/Object/Trait.pm', + 'lib/Moose/Meta/Role.pm', + 'lib/Moose/Meta/Role/Application.pm', + 'lib/Moose/Meta/Role/Application/RoleSummation.pm', + 'lib/Moose/Meta/Role/Application/ToClass.pm', + 'lib/Moose/Meta/Role/Application/ToInstance.pm', + 'lib/Moose/Meta/Role/Application/ToRole.pm', + 'lib/Moose/Meta/Role/Attribute.pm', + 'lib/Moose/Meta/Role/Composite.pm', + 'lib/Moose/Meta/Role/Method.pm', + 'lib/Moose/Meta/Role/Method/Conflicting.pm', + 'lib/Moose/Meta/Role/Method/Required.pm', + 'lib/Moose/Meta/TypeCoercion.pm', + 'lib/Moose/Meta/TypeCoercion/Union.pm', + 'lib/Moose/Meta/TypeConstraint.pm', + 'lib/Moose/Meta/TypeConstraint/Class.pm', + 'lib/Moose/Meta/TypeConstraint/DuckType.pm', + 'lib/Moose/Meta/TypeConstraint/Enum.pm', + 'lib/Moose/Meta/TypeConstraint/Parameterizable.pm', + 'lib/Moose/Meta/TypeConstraint/Parameterized.pm', + 'lib/Moose/Meta/TypeConstraint/Registry.pm', + 'lib/Moose/Meta/TypeConstraint/Role.pm', + 'lib/Moose/Meta/TypeConstraint/Union.pm', + 'lib/Moose/Object.pm', + 'lib/Moose/Role.pm', + 'lib/Moose/Spec/Role.pod', + 'lib/Moose/Unsweetened.pod', + 'lib/Moose/Util.pm', + 'lib/Moose/Util/MetaRole.pm', + 'lib/Moose/Util/TypeConstraints.pm', + 'lib/Moose/Util/TypeConstraints/Builtins.pm', + 'lib/Test/Moose.pm', + 'lib/metaclass.pm', + 'lib/oose.pm', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/000_load.t', + 't/attributes/accessor_context.t', + 't/attributes/accessor_inlining.t', + 't/attributes/accessor_override_method.t', + 't/attributes/accessor_overwrite_warning.t', + 't/attributes/attr_dereference_test.t', + 't/attributes/attribute_accessor_generation.t', + 't/attributes/attribute_custom_metaclass.t', + 't/attributes/attribute_delegation.t', + 't/attributes/attribute_does.t', + 't/attributes/attribute_inherited_slot_specs.t', + 't/attributes/attribute_lazy_initializer.t', + 't/attributes/attribute_names.t', + 't/attributes/attribute_reader_generation.t', + 't/attributes/attribute_required.t', + 't/attributes/attribute_traits.t', + 't/attributes/attribute_traits_n_meta.t', + 't/attributes/attribute_traits_parameterized.t', + 't/attributes/attribute_traits_registered.t', + 't/attributes/attribute_triggers.t', + 't/attributes/attribute_type_unions.t', + 't/attributes/attribute_without_any_methods.t', + 't/attributes/attribute_writer_generation.t', + 't/attributes/bad_coerce.t', + 't/attributes/chained_coercion.t', + 't/attributes/clone_weak.t', + 't/attributes/default_class_role_types.t', + 't/attributes/default_undef.t', + 't/attributes/delegation_and_modifiers.t', + 't/attributes/delegation_arg_aliasing.t', + 't/attributes/delegation_target_not_loaded.t', + 't/attributes/illegal_options_for_inheritance.t', + 't/attributes/inherit_lazy_build.t', + 't/attributes/lazy_no_default.t', + 't/attributes/method_generation_rules.t', + 't/attributes/misc_attribute_coerce_lazy.t', + 't/attributes/misc_attribute_tests.t', + 't/attributes/more_attr_delegation.t', + 't/attributes/no_init_arg.t', + 't/attributes/no_slot_access.t', + 't/attributes/non_alpha_attr_names.t', + 't/attributes/numeric_defaults.t', + 't/attributes/trigger_and_coerce.t', + 't/attributes/type_constraint.t', + 't/basics/always_strict_warnings.t', + 't/basics/basic_class_setup.t', + 't/basics/buildargs.t', + 't/basics/buildargs_warning.t', + 't/basics/create.t', + 't/basics/create_anon.t', + 't/basics/deprecations.t', + 't/basics/destruction.t', + 't/basics/error_handling.t', + 't/basics/global-destruction-helper.pl', + 't/basics/global_destruction.t', + 't/basics/import_unimport.t', + 't/basics/inner_and_augment.t', + 't/basics/load_into_main.t', + 't/basics/method_modifier_with_regexp.t', + 't/basics/methods.t', + 't/basics/moose_object_does.t', + 't/basics/moose_respects_type_constraints.t', + 't/basics/override_and_foreign_classes.t', + 't/basics/override_augment_inner_super.t', + 't/basics/rebless.t', + 't/basics/require_superclasses.t', + 't/basics/super_and_override.t', + 't/basics/super_warns_on_args.t', + 't/basics/universal_methods_wrappable.t', + 't/basics/wrapped_method_cxt_propagation.t', + 't/bugs/DEMOLISHALL.t', + 't/bugs/DEMOLISHALL_shortcutted.t', + 't/bugs/DEMOLISH_eats_exceptions.t', + 't/bugs/DEMOLISH_eats_mini.t', + 't/bugs/DEMOLISH_fails_without_metaclass.t', + 't/bugs/Moose_Object_error.t', + 't/bugs/anon_method_metaclass.t', + 't/bugs/application_metarole_compat.t', + 't/bugs/apply_role_to_one_instance_only.t', + 't/bugs/attribute_trait_parameters.t', + 't/bugs/augment_recursion_bug.t', + 't/bugs/coerce_without_coercion.t', + 't/bugs/constructor_object_overload.t', + 't/bugs/create_anon_recursion.t', + 't/bugs/create_anon_role_pass.t', + 't/bugs/delete_sub_stash.t', + 't/bugs/handles_foreign_class_bug.t', + 't/bugs/immutable_metaclass_does_role.t', + 't/bugs/immutable_n_default_x2.t', + 't/bugs/inheriting_from_roles.t', + 't/bugs/inline_reader_bug.t', + 't/bugs/instance_application_role_args.t', + 't/bugs/lazybuild_required_undef.t', + 't/bugs/mark_as_methods_overloading_breakage.t', + 't/bugs/moose_exporter_false_circular_reference_rt_63818.t', + 't/bugs/moose_octal_defaults.t', + 't/bugs/native_trait_handles_bad_value.t', + 't/bugs/overloading_edge_cases.t', + 't/bugs/reader_precedence_bug.t', + 't/bugs/role_caller.t', + 't/bugs/subclass_use_base_bug.t', + 't/bugs/subtype_conflict_bug.t', + 't/bugs/subtype_quote_bug.t', + 't/bugs/super_recursion.t', + 't/bugs/traits_with_exporter.t', + 't/bugs/type_constraint_messages.t', + 't/cmop/ArrayBasedStorage_test.t', + 't/cmop/AttributesWithHistory_test.t', + 't/cmop/BinaryTree_test.t', + 't/cmop/C3MethodDispatchOrder_test.t', + 't/cmop/ClassEncapsulatedAttributes_test.t', + 't/cmop/Class_C3_compatibility.t', + 't/cmop/InsideOutClass_test.t', + 't/cmop/InstanceCountingClass_test.t', + 't/cmop/LazyClass_test.t', + 't/cmop/Perl6Attribute_test.t', + 't/cmop/RT_27329_fix.t', + 't/cmop/RT_39001_fix.t', + 't/cmop/RT_41255.t', + 't/cmop/add_attribute_alternate.t', + 't/cmop/add_method_debugmode.t', + 't/cmop/add_method_modifier.t', + 't/cmop/advanced_methods.t', + 't/cmop/anon_class.t', + 't/cmop/anon_class_create_init.t', + 't/cmop/anon_class_keep_alive.t', + 't/cmop/anon_class_leak.t', + 't/cmop/anon_class_removal.t', + 't/cmop/anon_packages.t', + 't/cmop/attribute.t', + 't/cmop/attribute_duplication.t', + 't/cmop/attribute_errors_and_edge_cases.t', + 't/cmop/attribute_get_read_write.t', + 't/cmop/attribute_initializer.t', + 't/cmop/attribute_introspection.t', + 't/cmop/attribute_non_alpha_name.t', + 't/cmop/attributes.t', + 't/cmop/basic.t', + 't/cmop/before_after_dollar_under.t', + 't/cmop/class_errors_and_edge_cases.t', + 't/cmop/class_is_pristine.t', + 't/cmop/class_precedence_list.t', + 't/cmop/constant_codeinfo.t', + 't/cmop/create_class.t', + 't/cmop/custom_instance.t', + 't/cmop/deprecated.t', + 't/cmop/get_code_info.t', + 't/cmop/immutable_custom_trait.t', + 't/cmop/immutable_metaclass.t', + 't/cmop/immutable_w_constructors.t', + 't/cmop/immutable_w_custom_metaclass.t', + 't/cmop/inline_and_dollar_at.t', + 't/cmop/inline_structor.t', + 't/cmop/insertion_order.t', + 't/cmop/instance.t', + 't/cmop/instance_inline.t', + 't/cmop/instance_metaclass_incompat.t', + 't/cmop/instance_metaclass_incompat_dyn.t', + 't/cmop/lib/ArrayBasedStorage.pm', + 't/cmop/lib/AttributesWithHistory.pm', + 't/cmop/lib/BinaryTree.pm', + 't/cmop/lib/C3MethodDispatchOrder.pm', + 't/cmop/lib/ClassEncapsulatedAttributes.pm', + 't/cmop/lib/InsideOutClass.pm', + 't/cmop/lib/InstanceCountingClass.pm', + 't/cmop/lib/LazyClass.pm', + 't/cmop/lib/MyMetaClass.pm', + 't/cmop/lib/MyMetaClass/Attribute.pm', + 't/cmop/lib/MyMetaClass/Instance.pm', + 't/cmop/lib/MyMetaClass/Method.pm', + 't/cmop/lib/MyMetaClass/Random.pm', + 't/cmop/lib/Perl6Attribute.pm', + 't/cmop/lib/SyntaxError.pm', + 't/cmop/load.t', + 't/cmop/magic.t', + 't/cmop/make_mutable.t', + 't/cmop/meta_method.t', + 't/cmop/meta_package.t', + 't/cmop/meta_package_extension.t', + 't/cmop/metaclass.t', + 't/cmop/metaclass_incompatibility.t', + 't/cmop/metaclass_incompatibility_dyn.t', + 't/cmop/metaclass_inheritance.t', + 't/cmop/metaclass_loads_classes.t', + 't/cmop/metaclass_reinitialize.t', + 't/cmop/method.t', + 't/cmop/method_modifiers.t', + 't/cmop/methods.t', + 't/cmop/modify_parent_method.t', + 't/cmop/new_and_clone_metaclasses.t', + 't/cmop/null_stash.t', + 't/cmop/numeric_defaults.t', + 't/cmop/package_variables.t', + 't/cmop/random_eval_bug.t', + 't/cmop/rebless_instance.t', + 't/cmop/rebless_instance_away.t', + 't/cmop/rebless_overload.t', + 't/cmop/rebless_with_extra_params.t', + 't/cmop/scala_style_mixin_composition.t', + 't/cmop/self_introspection.t', + 't/cmop/subclasses.t', + 't/cmop/subname.t', + 't/cmop/universal_methods.t', + 't/compat/composite_metaroles.t', + 't/compat/extends_nonmoose_that_isa_moose_with_metarole.t', + 't/compat/foreign_inheritence.t', + 't/compat/inc_hash.t', + 't/compat/module_refresh_compat.t', + 't/compat/moose_respects_base.t', + 't/examples/Child_Parent_attr_inherit.t', + 't/examples/example1.t', + 't/examples/example2.t', + 't/examples/example_Moose_POOP.t', + 't/examples/example_Protomoose.t', + 't/examples/example_w_DCS.t', + 't/examples/example_w_TestDeep.t', + 't/examples/record_set_iterator.t', + 't/exceptions/attribute.t', + 't/exceptions/class-mop-attribute.t', + 't/exceptions/class-mop-class-immutable-trait.t', + 't/exceptions/class-mop-class.t', + 't/exceptions/class-mop-method-accessor.t', + 't/exceptions/class-mop-method-constructor.t', + 't/exceptions/class-mop-method-generated.t', + 't/exceptions/class-mop-method-meta.t', + 't/exceptions/class-mop-method-wrapped.t', + 't/exceptions/class-mop-method.t', + 't/exceptions/class-mop-mixin-hasattributes.t', + 't/exceptions/class-mop-mixin-hasmethods.t', + 't/exceptions/class-mop-module.t', + 't/exceptions/class-mop-object.t', + 't/exceptions/class-mop-package.t', + 't/exceptions/class.t', + 't/exceptions/cmop.t', + 't/exceptions/exception-lazyattributeneedsadefault.t', + 't/exceptions/frame-leak.t', + 't/exceptions/meta-role.t', + 't/exceptions/metaclass.t', + 't/exceptions/moose-exporter.t', + 't/exceptions/moose-meta-attribute-native-traits.t', + 't/exceptions/moose-meta-class-immutable-trait.t', + 't/exceptions/moose-meta-method-accessor-native-array.t', + 't/exceptions/moose-meta-method-accessor-native-collection.t', + 't/exceptions/moose-meta-method-accessor-native-grep.t', + 't/exceptions/moose-meta-method-accessor-native-hash-set.t', + 't/exceptions/moose-meta-method-accessor-native-hash.t', + 't/exceptions/moose-meta-method-accessor-native-string-match.t', + 't/exceptions/moose-meta-method-accessor-native-string-replace.t', + 't/exceptions/moose-meta-method-accessor-native-string-substr.t', + 't/exceptions/moose-meta-method-accessor-native.t', + 't/exceptions/moose-meta-method-accessor.t', + 't/exceptions/moose-meta-method-augmented.t', + 't/exceptions/moose-meta-method-constructor.t', + 't/exceptions/moose-meta-method-delegation.t', + 't/exceptions/moose-meta-method-destructor.t', + 't/exceptions/moose-meta-method-overridden.t', + 't/exceptions/moose-meta-role-application-rolesummation.t', + 't/exceptions/moose-meta-role-application-toclass.t', + 't/exceptions/moose-meta-role-application-torole.t', + 't/exceptions/moose-meta-role-application.t', + 't/exceptions/moose-meta-role-attribute.t', + 't/exceptions/moose-meta-role-composite.t', + 't/exceptions/moose-meta-typecoercion-union.t', + 't/exceptions/moose-meta-typecoercion.t', + 't/exceptions/moose-meta-typeconstraint-enum.t', + 't/exceptions/moose-meta-typeconstraint-parameterizable.t', + 't/exceptions/moose-meta-typeconstraint-parameterized.t', + 't/exceptions/moose-meta-typeconstraint-registry.t', + 't/exceptions/moose-meta-typeconstraint.t', + 't/exceptions/moose-role.t', + 't/exceptions/moose-util-metarole.t', + 't/exceptions/moose-util-typeconstraints.t', + 't/exceptions/moose.t', + 't/exceptions/object.t', + 't/exceptions/overload.t', + 't/exceptions/rt-92818.t', + 't/exceptions/rt-94795.t', + 't/exceptions/stringify.t', + 't/exceptions/traits.t', + 't/exceptions/typeconstraints.t', + 't/exceptions/util.t', + 't/immutable/apply_roles_to_immutable.t', + 't/immutable/buildargs.t', + 't/immutable/constructor_is_not_moose.t', + 't/immutable/constructor_is_wrapped.t', + 't/immutable/default_values.t', + 't/immutable/definition_context.t', + 't/immutable/immutable_constructor_error.t', + 't/immutable/immutable_destroy.t', + 't/immutable/immutable_meta_class.t', + 't/immutable/immutable_metaclass_with_traits.t', + 't/immutable/immutable_moose.t', + 't/immutable/immutable_roundtrip.t', + 't/immutable/immutable_trigger_from_constructor.t', + 't/immutable/inline_close_over.t', + 't/immutable/inline_fallbacks.t', + 't/immutable/inlined_constructors_n_types.t', + 't/immutable/multiple_demolish_inline.t', + 't/lib/Bar.pm', + 't/lib/Bar7/Meta/Trait.pm', + 't/lib/Bar7/Meta/Trait2.pm', + 't/lib/Foo.pm', + 't/lib/Moose/Meta/Attribute/Custom/Bar.pm', + 't/lib/Moose/Meta/Attribute/Custom/Foo.pm', + 't/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm', + 't/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm', + 't/lib/MyExporter.pm', + 't/lib/MyMetaclassRole.pm', + 't/lib/MyMooseA.pm', + 't/lib/MyMooseB.pm', + 't/lib/MyMooseObject.pm', + 't/lib/NoInlineAttribute.pm', + 't/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm', + 't/lib/Overloading/ClassWithCombiningRole.pm', + 't/lib/Overloading/ClassWithOneRole.pm', + 't/lib/Overloading/CombiningClass.pm', + 't/lib/Overloading/CombiningRole.pm', + 't/lib/Overloading/RoleConsumesOverloads.pm', + 't/lib/Overloading/RoleWithOverloads.pm', + 't/lib/Overloading/RoleWithoutOverloads.pm', + 't/lib/OverloadingTests.pm', + 't/lib/Real/Package.pm', + 't/lib/Role/BreakOnLoad.pm', + 't/lib/Role/Child.pm', + 't/lib/Role/Interface.pm', + 't/lib/Role/Parent.pm', + 't/metaclasses/create_anon_with_required_attr.t', + 't/metaclasses/custom_attr_meta_as_role.t', + 't/metaclasses/custom_attr_meta_with_roles.t', + 't/metaclasses/easy_init_meta.t', + 't/metaclasses/export_with_prototype.t', + 't/metaclasses/exporter_also_with_trait.t', + 't/metaclasses/exporter_meta_lookup.t', + 't/metaclasses/exporter_sub_names.t', + 't/metaclasses/goto_moose_import.t', + 't/metaclasses/immutable_metaclass_compat_bug.t', + 't/metaclasses/meta_name.t', + 't/metaclasses/metaclass_compat.t', + 't/metaclasses/metaclass_compat_no_fixing_bug.t', + 't/metaclasses/metaclass_compat_role_conflicts.t', + 't/metaclasses/metaclass_parameterized_traits.t', + 't/metaclasses/metaclass_traits.t', + 't/metaclasses/metarole.t', + 't/metaclasses/metarole_combination.t', + 't/metaclasses/metarole_on_anon.t', + 't/metaclasses/metarole_w_metaclass_pm.t', + 't/metaclasses/metaroles_of_metaroles.t', + 't/metaclasses/moose_exporter.t', + 't/metaclasses/moose_exporter_trait_aliases.t', + 't/metaclasses/moose_for_meta.t', + 't/metaclasses/moose_nonmoose_metatrait_init_order.t', + 't/metaclasses/moose_nonmoose_moose_chain_init_meta.t', + 't/metaclasses/moose_w_metaclass.t', + 't/metaclasses/new_metaclass.t', + 't/metaclasses/new_object_BUILD.t', + 't/metaclasses/overloading.t', + 't/metaclasses/reinitialize.t', + 't/metaclasses/use_base_of_moose.t', + 't/moose_util/apply_roles.t', + 't/moose_util/create_alias.t', + 't/moose_util/ensure_all_roles.t', + 't/moose_util/method_mod_args.t', + 't/moose_util/moose_util.t', + 't/moose_util/moose_util_does_role.t', + 't/moose_util/moose_util_search_class_by_role.t', + 't/moose_util/resolve_alias.t', + 't/moose_util/with_traits.t', + 't/native_traits/array_coerce.t', + 't/native_traits/array_from_role.t', + 't/native_traits/array_subtypes.t', + 't/native_traits/array_trigger.t', + 't/native_traits/collection_with_roles.t', + 't/native_traits/custom_instance.t', + 't/native_traits/hash_coerce.t', + 't/native_traits/hash_subtypes.t', + 't/native_traits/hash_trigger.t', + 't/native_traits/remove_attribute.t', + 't/native_traits/shallow_clone.t', + 't/native_traits/trait_array.t', + 't/native_traits/trait_bool.t', + 't/native_traits/trait_code.t', + 't/native_traits/trait_counter.t', + 't/native_traits/trait_hash.t', + 't/native_traits/trait_number.t', + 't/native_traits/trait_string.t', + 't/recipes/basics_bankaccount_methodmodifiersandsubclassing.t', + 't/recipes/basics_binarytree_attributefeatures.t', + 't/recipes/basics_company_subtypes.t', + 't/recipes/basics_datetime_extendingnonmooseparent.t', + 't/recipes/basics_document_augmentandinner.t', + 't/recipes/basics_genome_overloadingsubtypesandcoercion.t', + 't/recipes/basics_http_subtypesandcoercion.t', + 't/recipes/basics_point_attributesandsubclassing.t', + 't/recipes/extending_debugging_baseclassrole.t', + 't/recipes/extending_mooseish_moosesugar.t', + 't/recipes/legacy_debugging_baseclassreplacement.t', + 't/recipes/legacy_labeled_attributemetaclass.t', + 't/recipes/meta_globref_instancemetaclass.t', + 't/recipes/meta_labeled_attributetrait.t', + 't/recipes/meta_privateorpublic_methodmetaclass.t', + 't/recipes/meta_table_metaclasstrait.t', + 't/recipes/roles_applicationtoinstance.t', + 't/recipes/roles_comparable_codereuse.t', + 't/recipes/roles_restartable_advancedcomposition.t', + 't/roles/anonymous_roles.t', + 't/roles/application_toclass.t', + 't/roles/apply_role.t', + 't/roles/build.t', + 't/roles/conflict_many_methods.t', + 't/roles/create_role.t', + 't/roles/create_role_subclass.t', + 't/roles/empty_method_modifiers_meta_bug.t', + 't/roles/extending_role_attrs.t', + 't/roles/free_anonymous_roles.t', + 't/roles/imported_required_method.t', + 't/roles/meta_role.t', + 't/roles/method_aliasing_in_composition.t', + 't/roles/method_exclusion_in_composition.t', + 't/roles/method_modifiers.t', + 't/roles/methods.t', + 't/roles/more_alias_and_exclude.t', + 't/roles/more_role_edge_cases.t', + 't/roles/new_meta_role.t', + 't/roles/overloading_combine_to_class.t', + 't/roles/overloading_combine_to_instance.t', + 't/roles/overloading_combine_to_role.t', + 't/roles/overloading_composition_errors.t', + 't/roles/overloading_remove_attributes_bug.t', + 't/roles/overloading_to_class.t', + 't/roles/overloading_to_instance.t', + 't/roles/overloading_to_role.t', + 't/roles/overriding.t', + 't/roles/reinitialize_anon_role.t', + 't/roles/role.t', + 't/roles/role_attr_application.t', + 't/roles/role_attribute_conflict.t', + 't/roles/role_attrs.t', + 't/roles/role_compose_requires.t', + 't/roles/role_composite.t', + 't/roles/role_composite_exclusion.t', + 't/roles/role_composition_attributes.t', + 't/roles/role_composition_conflict_detection.t', + 't/roles/role_composition_errors.t', + 't/roles/role_composition_method_mods.t', + 't/roles/role_composition_methods.t', + 't/roles/role_composition_override.t', + 't/roles/role_composition_req_methods.t', + 't/roles/role_conflict_detection.t', + 't/roles/role_conflict_edge_cases.t', + 't/roles/role_consumers.t', + 't/roles/role_exclusion.t', + 't/roles/role_exclusion_and_alias_bug.t', + 't/roles/role_for_combination.t', + 't/roles/roles_and_method_cloning.t', + 't/roles/roles_and_req_method_edge_cases.t', + 't/roles/roles_applied_in_create.t', + 't/roles/run_time_role_composition.t', + 't/roles/runtime_roles_and_attrs.t', + 't/roles/runtime_roles_and_nonmoose.t', + 't/roles/runtime_roles_w_params.t', + 't/roles/use_base_does.t', + 't/test_moose/test_moose.t', + 't/test_moose/test_moose_does_ok.t', + 't/test_moose/test_moose_has_attribute_ok.t', + 't/test_moose/test_moose_meta_ok.t', + 't/test_moose/with_immutable.t', + 't/todo_tests/exception_reflects_failed_constraint.t', + 't/todo_tests/immutable_n_around.t', + 't/todo_tests/moose_and_threads.t', + 't/todo_tests/replacing_super_methods.t', + 't/todo_tests/required_role_accessors.t', + 't/todo_tests/role_attr_methods_original_package.t', + 't/todo_tests/role_insertion_order.t', + 't/todo_tests/various_role_features.t', + 't/todo_tests/wrong-inner.t', + 't/type_constraints/advanced_type_creation.t', + 't/type_constraints/class_subtypes.t', + 't/type_constraints/class_type_constraint.t', + 't/type_constraints/coerced_parameterized_types.t', + 't/type_constraints/container_type_coercion.t', + 't/type_constraints/container_type_constraint.t', + 't/type_constraints/custom_parameterized_types.t', + 't/type_constraints/custom_type_errors.t', + 't/type_constraints/define_type_twice_throws.t', + 't/type_constraints/duck_type_handles.t', + 't/type_constraints/duck_types.t', + 't/type_constraints/enum.t', + 't/type_constraints/inlining.t', + 't/type_constraints/match_type_operator.t', + 't/type_constraints/maybe_type_constraint.t', + 't/type_constraints/misc_type_tests.t', + 't/type_constraints/name_conflicts.t', + 't/type_constraints/normalize_type_name.t', + 't/type_constraints/parameterize_from.t', + 't/type_constraints/role_type_constraint.t', + 't/type_constraints/subtype_auto_vivify_parent.t', + 't/type_constraints/subtyping_parameterized_types.t', + 't/type_constraints/subtyping_union_types.t', + 't/type_constraints/throw_error.t', + 't/type_constraints/type_coersion_on_lazy_attributes.t', + 't/type_constraints/type_names.t', + 't/type_constraints/type_notation_parser.t', + 't/type_constraints/types_and_undef.t', + 't/type_constraints/union_is_a_type_of.t', + 't/type_constraints/union_types.t', + 't/type_constraints/union_types_and_coercions.t', + 't/type_constraints/util_find_type_constraint.t', + 't/type_constraints/util_more_type_coercion.t', + 't/type_constraints/util_std_type_constraints.t', + 't/type_constraints/util_type_coercion.t', + 't/type_constraints/util_type_constraints.t', + 't/type_constraints/util_type_constraints_export.t', + 't/type_constraints/util_type_reloading.t', + 't/type_constraints/with-specio.t', + 't/zzz-check-breaks.t' +); + +notabs_ok($_) foreach @files; +done_testing; diff --git a/xt/author/pod-coverage.t b/xt/author/pod-coverage.t new file mode 100644 index 0000000..b0d4f43 --- /dev/null +++ b/xt/author/pod-coverage.t @@ -0,0 +1,233 @@ + +use strict; +use warnings; + +use Test::More; + +use Test::Requires { + 'Test::Pod::Coverage' => '1.04', # skip all if not installed +}; + +# This is a stripped down version of all_pod_coverage_ok which lets us +# vary the trustme parameter per module. +my @modules + = grep { !/Accessor::Native.*$/ && !/::Conflicts$/ && !/^Moose::Exception::/ } all_modules(); +plan tests => scalar @modules; + +my %trustme = ( + 'Class::MOP' => [ + 'DEBUG_NO_META', + 'HAVE_ISAREV', + 'IS_RUNNING_ON_5_10', + 'subname', + 'in_global_destruction', + 'check_package_cache_flag', + 'load_first_existing_class', + 'is_class_loaded', + 'load_class', + ], + 'Class::MOP::Attribute' => ['process_accessors'], + 'Class::MOP::Class' => [ + + # deprecated + 'alias_method', + 'compute_all_applicable_attributes', + 'compute_all_applicable_methods', + + # unfinished feature + 'add_dependent_meta_instance', + 'add_meta_instance_dependencies', + 'invalidate_meta_instance', + 'invalidate_meta_instances', + 'remove_dependent_meta_instance', + 'remove_meta_instance_dependencies', + 'update_meta_instance_dependencies', + + # effectively internal + 'check_metaclass_compatibility', + 'clone_instance', + 'construct_class_instance', + 'construct_instance', + 'create_meta_instance', + 'reset_package_cache_flag', + 'update_package_cache_flag', + 'reinitialize', + + # doc'd with rebless_instance + 'rebless_instance_away', + + # deprecated + 'get_attribute_map', + ], + 'Class::MOP::Class::Immutable::Trait' => ['.+'], + 'Class::MOP::Class::Immutable::Class::MOP::Class' => ['.+'], + 'Class::MOP::Deprecated' => ['.+'], + 'Class::MOP::Instance' => [ + qw( BUILDARGS + bless_instance_structure + is_dependent_on_superclasses ), + ], + 'Class::MOP::Instance' => [ + qw( BUILDARGS + bless_instance_structure + is_dependent_on_superclasses ), + ], + 'Class::MOP::Method::Accessor' => [ + qw( generate_accessor_method + generate_accessor_method_inline + generate_clearer_method + generate_clearer_method_inline + generate_predicate_method + generate_predicate_method_inline + generate_reader_method + generate_reader_method_inline + generate_writer_method + generate_writer_method_inline + initialize_body + ) + ], + 'Class::MOP::Method::Constructor' => [ + qw( attributes + generate_constructor_method + generate_constructor_method_inline + initialize_body + meta_instance + options + ) + ], + 'Class::MOP::Method::Generated' => [ + qw( new + definition_context + is_inline + initialize_body + ) + ], + 'Class::MOP::MiniTrait' => ['.+'], + 'Class::MOP::Mixin::AttributeCore' => ['.+'], + 'Class::MOP::Mixin::HasAttributes' => ['.+'], + 'Class::MOP::Mixin::HasMethods' => ['.+'], + 'Class::MOP::Mixin::HasOverloads' => ['.+'], + 'Class::MOP::Overload' => [ 'attach_to_class' ], + 'Class::MOP::Package' => [ 'get_method_map', 'wrap_method_body' ], + 'Moose' => [ 'init_meta', 'throw_error' ], + 'Moose::Error::Confess' => ['new'], + 'Moose::Exception' => ['BUILD'], + 'Moose::Meta::Attribute' => [ + qw( interpolate_class + throw_error + attach_to_class + ) + ], + 'Moose::Meta::Attribute::Native::MethodProvider::Array' => ['.+'], + 'Moose::Meta::Attribute::Native::MethodProvider::Bool' => ['.+'], + 'Moose::Meta::Attribute::Native::MethodProvider::Code' => ['.+'], + 'Moose::Meta::Attribute::Native::MethodProvider::Counter' => ['.+'], + 'Moose::Meta::Attribute::Native::MethodProvider::Hash' => ['.+'], + 'Moose::Meta::Attribute::Native::MethodProvider::String' => ['.+'], + 'Moose::Meta::Class' => [ + qw( check_metaclass_compatibility + construct_instance + create_error + raise_error + reinitialize + superclasses + ) + ], + 'Moose::Meta::Class::Immutable::Trait' => ['.+'], + 'Moose::Meta::Method' => ['throw_error'], + 'Moose::Meta::Method::Accessor' => [ + qw( generate_accessor_method + generate_accessor_method_inline + generate_clearer_method + generate_predicate_method + generate_reader_method + generate_reader_method_inline + generate_writer_method + generate_writer_method_inline + new + ) + ], + 'Moose::Meta::Method::Constructor' => [ + qw( attributes + initialize_body + meta_instance + new + options + ) + ], + 'Moose::Meta::Method::Destructor' => [ 'initialize_body', 'options' ], + 'Moose::Meta::Method::Meta' => ['wrap'], + 'Moose::Meta::Role' => [ + qw( alias_method + get_method_modifier_list + reinitialize + reset_package_cache_flag + update_package_cache_flag + wrap_method_body + ) + ], + 'Moose::Meta::Mixin::AttributeCore' => ['.+'], + 'Moose::Meta::Role::Composite' => [ + qw( add_method + get_method + get_method_list + has_method + is_anon + add_overloaded_operator + get_all_overloaded_operators + get_overload_fallback_value + is_overloaded + set_overload_fallback_value + ), + ], + 'Moose::Object' => [ 'BUILDALL', 'DEMOLISHALL' ], + 'Moose::Role' => [ + qw( after + around + augment + before + extends + has + inner + override + super + with + init_meta ) + ], + 'Moose::Meta::TypeCoercion' => ['compile_type_coercion'], + 'Moose::Meta::TypeCoercion::Union' => ['compile_type_coercion'], + 'Moose::Meta::TypeConstraint' => [qw( compile_type_constraint inlined )], + 'Moose::Meta::TypeConstraint::Class' => + [qw( equals is_a_type_of is_a_subtype_of )], + 'Moose::Meta::TypeConstraint::Enum' => [qw( constraint equals )], + 'Moose::Meta::TypeConstraint::DuckType' => + [qw( constraint equals get_message )], + 'Moose::Meta::TypeConstraint::Parameterizable' => ['.+'], + 'Moose::Meta::TypeConstraint::Parameterized' => ['.+'], + 'Moose::Meta::TypeConstraint::Role' => [qw( equals is_a_type_of )], + 'Moose::Meta::TypeConstraint::Union' => [ + qw( compile_type_constraint + coercion + has_coercion + can_be_inlined + inline_environment ) + ], + 'Moose::Util' => ['add_method_modifier'], + 'Moose::Util::MetaRole' => ['apply_metaclass_roles'], + 'Moose::Util::TypeConstraints' => ['find_or_create_type_constraint'], + 'Moose::Util::TypeConstraints::Builtins' => ['.+'], +); + +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" + ); +} diff --git a/xt/author/pod-spell.t b/xt/author/pod-spell.t new file mode 100644 index 0000000..b4685ee --- /dev/null +++ b/xt/author/pod-spell.t @@ -0,0 +1,382 @@ +use strict; +use warnings; + +use Test::Spelling; + +my @stopwords; +for (<DATA>) { + chomp; + push @stopwords, $_ + unless /\A (?: \# | \s* \z)/msx; # skip comments, whitespace +} + +add_stopwords(@stopwords); +local $ENV{LC_ALL} = 'C'; +set_spell_cmd('aspell list -l en'); +all_pod_files_spelling_ok; + +__DATA__ +## personal names +Aankhen +Anders +Aran +Breunung +Buels +Cawley +Clary +Crawley +Debolaz +Deltac +Doran +Etheridge +Florian +Gabor +Goro +Goulah +Hardison +JT +Kanat +Kansai +Kinyon +Kinyon's +Kogman +Lanyon +Lenz +Luehrs +McWhirter +Moritz +Pearcey +Perek +Piotr +Prather +Ragwitz +Reis +Rockway +Roditi +Rolsky +Roszatycki +Roszatycki's +SL +SawyerX +Sedlacek +Shlomi +Signes +Simula +Stevan +Stratman +Szabo +Treder +Vecchi +Vilain +Ynon +Yuval +autarch +backported +backports +blblack +bluefeet +brian +chansen +chromatic's +dexter +doy +ewilhelm +foy +frodwith +gphat +groditi +hakobe +ingy +jgoulah +jrockway +kolibrie +konobi +lbr +merlyn +mst +nothingmuch +perigrin +phaylon +rafl +rindolf +rjbs +rlb +robkinyon +sartak +stevan +tozt +wreis + +## proper names +AOP +CLOS +CPAN +CentOS +FOSDEM +OCaml +OnLAMP +PDX +PerlMaven +SHDH +SVN +WebGUI +ohloh +osdc +tw + +## Moose +AttributeHelpers +BUILDALL +BUILDARGS +BankAccount +BankAccount's +BinaryTree +CLR +CheckingAccount +DEMOLISHALL +Debuggable +JVM +METACLASS +Metaclass +MOPs +MetaModel +MetaObject +Metalevel +MooseX +Num +OtherName +PosInt +PositiveInt +RoleSummation +Specio +Str +TypeContraints +clearers +composable +hardcode +immutabilization +immutabilize +introspectable +metaclass +metaclass's +metadata +metaobject +metaobjects +metaprogrammer +metarole +metaroles +metatraits +mixins +oose +ro +rw +AttributeIsRequired +ValidationFailedForTypeConstraint + +## computerese +API +APIs +Baz +Bugzilla +Changelog +Coercions +DUCKTYPE +DWIM +GitHub +GitHub's +Haskell +IRC +Immutabilization +Inlinable +JSON +Lexically +Namespace +O'Caml +OO +OOP +ORM +OSCON +Overengineered +ROLETYPE +SUBCLASSES +SUBTYPES +Smalltalk +Subclasses +Subtypes +TODO +UNIMPORTING +URI +Unported +Whitelist +Whitepaper +Wikipedia +# from the Support manual talking about version numbers +YY +YYZZ +ZZ +arity +arrayrefs +autodelegation +blog +clearers +codebase +coercions +committer +committers +compat +continutation +contrib +datetimes +dec +decrement +definedness +deinitialized +deprecations +destructor +destructors +destructuring +dev +discoverable +env +eval'ing +extensibility +hashrefs +hotspots +immutabilize +immutabilized +immutabilizes +incrementing +inlinable +inline +inlines +installable +instantiation +interoperable +invocant +invocant's +irc +isa +kv +login +matcher +metadata +mixin +mixins +mortem +mul +munge +namespace +namespace's +namespaced +namespaces +namespacing +natatime +# as in required-ness +ness +online +optimizations +overridable +parameterizable +parameterization +parameterize +parameterized +parameterizes +params +pluggable +plugins +polymorphism +prechecking +prepends +pu +rebase +rebased +rebasing +rebless +reblesses +reblessing +refactored +refactoring +rethrows +runtime +serializer +sigil +sigils +stacktrace +stacktraces +stateful +subclass's +subclassable +subclasses +subname +subtype +subtypes +subtyping +unblessed +unexport +unimporting +uninitialize +unordered +unresolvable +unsets +unsettable +utils +whitelisted +workflow +workflows + +## other jargon +bey +gey + +## neologisms +breakability +delegatee +featureful +hackery +hacktern +undeprecate +wrappee + +## compound +# half-assed +assed +# role-ish, Ruby-ish, medium-to-large-ish +ish +# kool-aid +kool +# pre-5.10 +pre +# vice versa +versa +lookup +# co-maint +maint + +## slang +C'mon +might've +Nuff + +## things that should be in the dictionary, but are not +attribute's +declaratively +everybody's +everyone's +human's +indices +initializers +newfound +reimplements +reinitializes +specializer +unintrusive + +## misspelt on purpose +emali +uniq + +#docgenerator +fixLineLength +getExceptionsToMessages +placeCommasAndAnd +shortenToEighty diff --git a/xt/author/test-my-dependents.t b/xt/author/test-my-dependents.t new file mode 100644 index 0000000..4a6d5ae --- /dev/null +++ b/xt/author/test-my-dependents.t @@ -0,0 +1,808 @@ +use strict; +use warnings; + +use Cwd qw( abs_path ); +use Test::More; + +BEGIN { + my $help = <<'EOF'; +This test will not run unless you set MOOSE_TEST_MD to a true value. + + Valid values are: + + all Test every dist which depends on Moose except those + that we know cannot be tested. This is a lot of + distros (thousands). + + Dist::1,Dist::2,... Test the individual dists listed. + + MooseX Test all Moose extension distros + (MooseX modules plus a few others). + + 1 Run the default tests. We pick 200 random dists and + test them. + +EOF + + plan skip_all => $help + unless $ENV{MOOSE_TEST_MD}; +} + +use Test::Requires { + 'Archive::Zip' => 0, # or else .zip dists won't be able to be installed + 'Test::DependentModules' => '0.13', + 'MetaCPAN::API' => '0.33', +}; + +use Test::DependentModules qw( test_module ); + +use DateTime; +use List::Util 1.33 qw(any); +use Moose (); + +diag( 'Test run performed at: ' + . DateTime->now + . ' with Moose ' + . (Moose->VERSION || 'git repo') ); + +$ENV{PERL_TEST_DM_LOG_DIR} = abs_path('.'); +delete @ENV{ qw( AUTHOR_TESTING RELEASE_TESTING SMOKE_TESTING ) }; + +$ENV{ANY_MOOSE} = 'Moose'; + +my $mcpan = MetaCPAN::API->new; +my $res = $mcpan->post( + '/release/_search' => { + query => { match_all => {} }, + size => 5000, + filter => { and => [ + { or => [ + { term => { 'release.dependency.module' => 'Moose' } }, + { term => { 'release.dependency.module' => 'Moose::Role' } }, + { term => { 'release.dependency.module' => 'Moose::Exporter' } }, + { term => { 'release.dependency.module' => 'Class::MOP' } }, + { term => { 'release.dependency.module' => 'MooseX::Role::Parameterized' } }, + { term => { 'release.dependency.module' => 'Any::Moose' } }, + ] }, + { term => { 'release.status' => 'latest' } }, + { term => { 'release.maturity' => 'released' } }, + ] }, + fields => 'distribution' + } +); + +my @skip_prefix = qw(Acme Task Bundle); +my %skip; +my %todo; + +my $hash; +for my $line (<DATA>) { + chomp $line; + next unless $line =~ /\S/; + if ( $line =~ /^# (\w+)/ ) { + die "Invalid action in DATA section ($1)" + unless $1 eq 'SKIP' || $1 eq 'TODO'; + $hash = $1 eq 'SKIP' ? \%skip : \%todo; + } + + my ( $dist, $reason ) = $line =~ /^(\S*)\s*(?:#\s*(.*)\s*)?$/; + next unless defined $dist && length $dist; + + $hash->{$dist} = $reason; +} + +my %name_fix = ( + 'AI-Classifier' => 'AI::Classifier::Text', + 'Algorithm-DependencySolver' => 'Algorithm::DependencySolver::Solver', + 'Alice' => 'Alice::HTTP::WebSocket', + 'App-Foca' => 'App::Foca::Server', + 'App-passmanager' => 'App::PassManager', + 'App-PipeFilter' => 'App::PipeFilter::Generic', + 'Bio_AssemblyImprovement' => 'Bio::AssemblyImprovement', + 'Business-PaperlessTrans' => 'Business::PaperlessTrans::Client', + 'BuzzSaw' => 'App::BuzzSaw', + 'Constructible' => 'Constructible::Maxima', + 'CTKlib' => 'CTK', + 'DCOLLINS-ANN-Locals' => 'DCOLLINS::ANN::Robot', + 'Dist-Zilla-Deb' => 'Dist::Zilla::Plugin::Deb::VersionFromChangelog', + 'Dist-Zilla-Plugins-CJM' => 'Dist::Zilla::Plugin::TemplateCJM', + 'Dist-Zilla-Plugin-TemplateFile' => 'Dist::Zilla::Plugin::TemplateFiles', + 'DSL-Tiny' => 'DSL::Tiny::Role', + 'Google-Directions' => 'Google::Directions::Client', + 'GoogleMapsHeatmap' => 'Geo::Heatmap', + 'helm' => 'Helm', + 'HTML-Untemplate' => 'HTML::Linear', + 'marc-moose' => 'MARC::Moose', + 'mobirc' => 'App::Mobirc', + 'Net-Amazon-EMR' => 'Net::Amazon::EMR::AddInstanceGroupsResult', + 'OWL-Simple' => 'OWL::Simple::Class', + 'Patterns-ChainOfResponsibility' => 'Patterns::ChainOfResponsibility::Application', + 'PkgForge' => 'PkgForge::App', + 'PkgForge-Server' => 'PkgForge::Builder', + 'Pod-Elemental-Transfomer-VimHTML' => 'Pod::Elemental::Transformer::VimHTML', + 'Role-Identifiable' => 'Role::Identifiable::HasIdent', + 'smokebrew' => 'App::SmokeBrew', + 'Treex-Parser-MSTperl' => 'Treex::Tool::Parser::MSTperl', + 'v6-alpha' => 'v6', + 'WebService-LOC-CongRec' => 'WebService::LOC::CongRec::Crawler', + 'X11-XCB' => 'X11::XCB::Connection', + 'XML-Ant-BuildFile' => 'XML::Ant::BuildFile::Project', +); + +my @dists = sort + grep { !$skip{$_} } + grep { my $dist = $_; !any { $dist =~ /^$_-/ } @skip_prefix } + map { $_->{fields}{distribution} } + @{ $res->{hits}{hits} }; + +if ( $ENV{MOOSE_TEST_MD} eq 'MooseX' ) { + @dists = grep { + /^(?:MooseX-|(?:Fey-ORM|KiokuDB|Bread-Board|Catalyst-Runtime|Reflex)$)/ + } @dists; +} +elsif ( $ENV{MOOSE_TEST_MD} eq '1' ) { + diag( + <<'EOF' + Picking 200 random dependents to test. Set MOOSE_TEST_MD=all to test all + dependents or MOOSE_TEST_MD=MooseX to test extension modules only. +EOF + ); + + my %indexes; + while ( keys %indexes < 200 ) { + $indexes{ int rand( scalar @dists ) } = 1; + } + + @dists = @dists[ sort keys %indexes ]; +} +elsif ( $ENV{MOOSE_TEST_MD} ne 'all' ) { + my @chosen = split /,/, $ENV{MOOSE_TEST_MD}; + my %dists = map { $_ => 1 } @dists; + if (my @unknown = grep { !$dists{$_} } @chosen) { + die "Unknown dists: @unknown"; + } + @dists = @chosen; +} + +plan tests => scalar @dists; +for my $dist (@dists) { + note($dist); + my $module = $dist; + $module = $name_fix{$module} if exists $name_fix{$module}; + if ($todo{$dist}) { + my $reason = $todo{$dist}; + $reason = '???' unless defined $reason; + local $TODO = $reason; + eval { test_module($module); 1 } + or fail("Died when testing $module: $@"); + } + else { + eval { test_module($module); 1 } + or fail("Died when testing $module: $@"); + } +} + +__DATA__ +# SKIP: doesn't install deps properly (test::dm bugs?) +App-Benchmark-Accessors # Mojo::Base isn't installed +Bot-BasicBot-Pluggable # Crypt::SaltedHash isn't installed +Chart-Clicker # Layout::Manager::Compass isn't installed +Chart-Weather-Forecast # Layout::Manager::Compass isn't installed +Code-Statistics # MooseX::HasDefaults::RO isn't installed +Connector # Config::Versioned isn't installed +Context-Set # Lingua::EN::Words2Nums isn't installed +DBIx-Class-DeploymentHandler # Lingua::EN::Words2Nums isn't installed +DBIx-Class-Migration # Lingua::EN::Words2Nums isn't installed +DBIx-Class-Migration-RunScript-Trait-AuthenPassphrase # Lingua::EN::Words2Nums isn't installed +DBIx-Class-Schema-Loader # Lingua::EN::Words2Nums isn't installed +DBIx-ObjectMapper # Class::Accessor::Chained::Fast isn't installed +Dependencies-Searcher # ack binary isn't installed, because test::dm doesn't set up $PATH +Dist-Zilla-PluginBundle-AJGB # Dist::Zilla::Plugin::KwaliteeTests isn't installed +Dist-Zilla-PluginBundle-Author-BBYRD # Dist::Zilla::Plugin::ReportPhase isn't installed +Dist-Zilla-PluginBundle-JQUELIN # Dist::Zilla::Plugin::CompileTests isn't installed +Dist-Zilla-PluginBundle-MITHALDU # List::AllUtils isn't installed +Dist-Zilla-PluginBundle-NIGELM # Dist::Zilla::Plugin::KwaliteeTests isn't installed +Dist-Zilla-PluginBundle-PDONELAN # Dist::Zilla::Plugin::CompileTests isn't installed +Dist-Zilla-Util-FileGenerator # MooseX::HasDefaults::RO isn't installed +EBI-FGPT-FuzzyRecogniser # GO::Parser isn't installed +Erlang-Parser # Parse::Yapp::Driver isn't installed +Foorum # Sphinx::Search isn't installed +Grimlock # DBIx::Class::EncodedColumn isn't installed +Locale-Handle-Pluggable # MooseX::Types::VariantTable::Declare isn't installed +Message-Passing-STOMP # Message::Passing isn't installed +mobirc # HTTP::Session::State::GUID isn't installed +Net-Bamboo # XML::Tidy isn't installed +OpenERP-OOM # OpenERP::XMLRPC::Client isn't installed +Tatsumaki-Template-Markapl # Tatsumaki::Template isn't installed +Text-Tradition # Bio::Phylo::IO isn't installed +Text-Tradition-Analysis # Bio::Phylo::IO isn't installed +WebService-Strava # Any::URI::Escape isn't installed + +# SKIP: index issues (test::dm bugs?) +Hopkins # can't find on cpan +PostScript-Barcode # can't find on cpan + +# SKIP: no tests +AI-ExpertSystem-Advanced # no tests +API-Assembla # no tests +App-mkfeyorm # no tests +App-passmanager # no tests +App-Scrobble # no tests +Bot-Applebot # no tests +Catalyst-Authentication-Credential-Facebook-OAuth2 # no tests +Catalyst-Authentication-Store-Fey-ORM # no tests +Catalyst-Controller-MovableType # no tests +Catalyst-Model-MenuGrinder # no tests +Chef # no tests +Data-SearchEngine-ElasticSearch # no tests +Dist-Zilla-MintingProfile-Author-ARODLAND # no tests +Dist-Zilla-PluginBundle-ARODLAND # no tests +Dist-Zilla-PluginBundle-Author-OLIVER # no tests +Dist-Zilla-PluginBundle-NUFFIN # no tests +Dist-Zilla-Plugin-DualLife # no tests +Dist-Zilla-Plugin-Git-Describe # no tests +Dist-Zilla-Plugin-GitFlow # no tests +Dist-Zilla-Plugin-GitFmtChanges # no tests +Dist-Zilla-Plugin-MetaResourcesFromGit # no tests +Dist-Zilla-Plugin-ModuleBuild-OptionalXS # no tests +Dist-Zilla-Plugin-Rsync # no tests +Dist-Zilla-Plugin-TemplateFile # no tests +Dist-Zilla-Plugin-UploadToDuckPAN # no tests +Finance-Bank-SuomenVerkkomaksut # no tests +Games-HotPotato # no tests +IO-Storm # no tests +JIRA-Client-REST # no tests +Kafka-Client # no tests +LWP-UserAgent-OfflineCache # no tests +Markdown-Pod # no tests +meon-Web # no tests +MooseX-Types-DateTimeX # no tests +MooseX-Types-DateTime-MoreCoercions # no tests unless DateTime::Format::DateManip is installed +Net-Azure-BlobService # no tests +Net-Dropbox # no tests +Net-Flowdock # no tests +Net-OpenStack-Attack # no tests +Net-Ostrich # no tests +Net-Recurly # no tests +OpenDocument-Template # no tests +Pod-Weaver-Section-Consumes # no tests +Pod-Weaver-Section-Encoding # no tests +Pod-Weaver-Section-Extends # no tests +P50Tools # no tests +POE-Component-Server-MySQL # no tests +Prophet-Devel # no tests +Random-Quantum # no tests +SchemaEvolution # no tests +STD # no tests +Test-System # no tests +Test-WWW-Mechanize-Dancer # no tests +WebService-Buxfer # no tests +WebService-CloudFlare-Host # no tests +WWW-MenuGrinder # no tests +WWW-UsePerl-Server # no tests +WWW-WuFoo # no tests + +# SKIP: external dependencies +Alien-Ditaa # runs java code +Ambrosia # required mod_perl +AnyEvent-MSN # requires Net::SSLeay (which requires libssl) +AnyEvent-Multilog # requires multilog +AnyEvent-Net-Curl-Queued # requires libcurl +AnyEvent-ZeroMQ # requires zeromq installation +AnyMQ-ZeroMQ # requires zeromq installation +Apache2-HttpEquiv # requires apache (for mod_perl) +App-Fotagger # requires sdl +App-Mimosa # requires fastacmd +App-PgCryobit # requires postgres installation +App-SimplenoteSync # requires File::ExtAttr which requires libattr +App-WIoZ # requires cairo +Archive-RPM # requires cpio +Bio-MLST-Check # requires makeblastdb, etc +Bio-Pipeline-Comparison # requires bgzip, tabix, etc +Bot-Jabbot # requires libidn +Catalyst-Authentication-Store-CouchDB # requires couchdb +Catalyst-Engine-Stomp # depends on alien::activemq +Catalyst-Plugin-Session-Store-Memcached # requires memcached +Catalyst-View-SVG-TT-Graph # requires librsvg +Catalyst-View-Template-PHP # requires php +Cave-Wrapper # requires cave to be installed +CHI-Driver-Redis # requires redis server +Crypt-Random-Source-Strong-Win32 # windows only +Curses-Toolkit # requires Curses which requires ncurses library +Dackup # requires ssh +Dancer2-Plugin-Queue-MongoDB # requires mongo +Data-Collector # requires ssh +Data-Riak # requires riak +Database-Migrator-mysql # requires mysql installation +DBIx-MySQL-Replication-Slave # requires mysql installation +DBIx-PgLink # requires postgres installation +Device-SMBus # requires libi2c +Device-ZyXEL-IES # SNMP requires net-snmp +Dist-Zilla-Plugin-ChangelogFromGit-Debian-Sequential # requires dpkg +Dist-Zilla-Plugin-Subversion # requires svn bindings +Dist-Zilla-Plugin-SVK # requires svn bindings +Dist-Zilla-Plugin-SvnObtain # requires svn bindings +Dist-Zilla-Plugin-Upload-SCP # requires ssh +Fedora-App-MaintainerTools # requires rpm to be installed +Fedora-App-ReviewTool # requires koji to be installed +Fuse-Template # requires libfuse +Games-HotPotato # requires sdl +Games-Tetris-Complete # requires threads +Gapp # requires gtk2 +GappX-NoticeBox # requires gtk2 +GnuPG-Interface # requires gpg +GoogleMapsHeatmap # requires imagemagick +Graphics-DZI # requires imagemagick +Graphics-Primitive-Driver-Cairo # requires cairo +Graphics-Primitive-Driver-CairoPango # requires cairo +helm # requires ssh +HTML-Barcode-QRCode # requires libqrencode +Hypatia-Chart-Clicker # requires cairo +Hypatia-GraphViz2 # requires graphviz +Image-Placeholder # requires gd +Image-TextMode # requires gd +IRC-RemoteControl # requires libssh2 +JavaScript-Sprockets # requires sprocketize +JavaScript-V8x-TestMoreish # requires v8 +Koha-Contrib-Tamil # requires yaz +K # requires kx +Lighttpd-Control # requires lighttpd +Lingua-TreeTagger # requires treetagger to be installed +Lorem # requires cairo +Math-Lsoda # requires f77 +Message-Passing-PSGI # requires zeromq installation +Message-Passing-ZeroMQ # requires zeromq installation +MongoDBI # requires mongo +MongoDB # requires mongo +MongoDB-Async # requires mongo +MSWord-ToHTML # requires abiword to be installed +MySQL-Slurp # requires mysql +Net-DBus-Skype # requires dbus +Net-Route # requires route +Net-SFTP-Foreign-Exceptional # depends on running ssh +Net-UpYun # requires curl +Net-ZooTool # requires curl +Nginx-Control # requires nginx to be installed +NLP-Service # requires javac +Padre-Plugin-Cookbook # requires Wx +Padre-Plugin-Moose # requires threaded perl +Padre-Plugin-PDL # requires threaded perl +Padre-Plugin-Snippet # requires threaded perl +Paludis-UseCleaner # depends on cave::wrapper +Pantry # requires ssh +Perlanet # HTML::Tidy requires tidyp +Perl-Dist-Strawberry-BuildPerl-5123 # windows only +Perl-Dist-Strawberry-BuildPerl-5123 # windows only +Perl-Dist-WiX-BuildPerl-5123 # windows only +Perl-Dist-WiX # windows only +Perl-Dist-WiX # windows only +Physics-UEMColumn # requires gsl +PkgForge # requires rpm +PkgForge-Registry # requires rpm +PkgForge-Server # requires rpm +Plack-App-FakeApache # requires mod_perl +POE-Component-OpenSSH # requires ssh +PulseAudio # requires pulseaudio +RDF-TrineX-RuleEngine-Jena # requires Jena +Reflexive-ZmqSocket # requires zmq +SDLx-Betweener # requires sdl +SDLx-GUI # requires sdl +Siebel-COM # windows only +SimpleDB-Class # requires memcached +SVN-Simple-Hook # requires svn +SVN-Tree # requires svn +Tapper-Cmd # requires ssh +Tapper-MCP # depends on everything under the sun - some of which is broken +Template-JavaScript # requires v8 +Test-Approvals # windows only +Test-DBIx-Class # requires mysql +Test-Gearman # requires gearman +TheSchwartz-Moosified # requires DBI::Pg ? +UAV-Pilot # requires sdl +WebService-SendGrid # requires curl +WebService-Tesco-API # requires curl +WWW-Contact # depends on curl +WWW-Curl-Simple # requires curl +ZeroMQ-PubSub # requires zmq +ZMQ-Declare # requires zmq +ZMQx-Class # requires zmq + +# SKIP: flaky internet tests +iTransact-Lite # tests rely on internet site +Unicode-Emoji-E4U # tests rely on internet site +WWW-eNom # tests rely on internet site +WWW-Finances-Bovespa # tests rely on internet site +WWW-Vimeo-Download # tests rely on internet site +WWW-YouTube-Download-Channel # tests rely on internet site + +# SKIP: graphical +App-CPAN2Pkg # tk tests are graphical +App-USBKeyCopyCon # gtk tests are graphical +CatalystX-Restarter-GTK # gtk tests are graphical +Forest-Tree-Viewer-Gtk2 # gtk tests are graphical +Games-Pandemic # tk tests are graphical +Games-RailRoad # tk tests are graphical +Games-Risk # tk tests are graphical +Log-Dispatch-Gtk2-Notify # gtk tests are graphical +LPDS # gtk tests are graphical +Periscope # gtk tests are graphical +Tk-Role-Dialog # tk tests are graphical +Weaving-Tablet # tk tests are graphical + +# SKIP: prompts (or a dep prompts) or does something else dumb +AI-Nerl # pdl has weird memory errors and hangs +Bio-Tradis # Bio::DB::Sam prompts in Makefile.PL +Bot-Backbone # poe-loop-ev prompts +Cache-Ehcache # hangs if server exists on port 8080 +Cache-Memcached-Queue # Makefile.PL tries to auto-install deps manually +CM-Permutation # OpenGL uses graphics in Makefile.PL +Date-Biorhythm # Date::Business prompts in Makefile.PL +DBIx-VersionedDDL # runs a script with /usr/bin/perl in the shbang line +File-Tail-Scribe # tests hang +Gearman-Driver # spews tar errors +Gearman-SlotManager # tests hang +IPC-AnyEvent-Gearman # tests hang +Lingua-YALI # runs scripts with /usr/bin/env perl in the shbang line +Net-SSH-Mechanize # the mock-ssh script it runs seems to spin endlessly +POE-Component-Server-SimpleHTTP-PreFork # tests hang +Test-SFTP # Term::ReadPassword prompts in tests +WebService-FogBugz-XML # prompts +WWW-Hashdb # test hangs, pegging cpu +Zucchini # File::Rsync prompts in Makefile.PL + +# SKIP: broken configure +Module-Install-ProvidesClass # broken Makefile.PL +Nagios-Interface # broken Makefile.PL +TAP-Runner # Math::Cartesian::Product is broken + +# TODO: failing for a reason +Algorithm-KernelKMeans # mx-types-common changes broke it +Alien-BWIPP # given is experimental +AnyEvent-BitTorrent # broken +AnyEvent-Cron # intermittent failures +AnyEvent-Inotify-Simple # ??? (maybe issue with test::sweet) +AnyEvent-JSONRPC # tests require recommended deps +AnyEvent-Retry # mx-types-common changes broke it +AnyMongo # doesn't compile +App-ArchiveDevelCover # depends on nonexistent testdata::setup +App-Dataninja # bad M::I install in inc/ +App-Foca # pod coverage fail +App-HistHub # missing deps +App-iTan # given is experimental +App-Magpie # deps on URPM which doesn't exist +App-MediaWiki2Git # git::repository is broken +App-Munchies # depends on XML::DTD +App-PM-Announce # deps on WWW::UsePerl::Journal::Post which doesn't exist +App-Rssfilter # given is experimental +App-Services # misnamed package +App-TemplateServer # broken use of types +App-TemplateServer-Provider-HTML-Template # dep on app-templateserver +App-TemplateServer-Provider-Mason # dep on app-templateserver +App-TemplateServer-Provider-TD # dep on app-templateserver +App-TimeTracker # missing dep on IO::Capture::Stdout +App-Twimap # dep on Web::oEmbed::Common +App-Twitch # given is experimental +App-Validation-Automation # dep on Switch +App-Wubot # broken +Archive-BagIt # pod coverage fail +Argon # missin dep on IO::Capture::Stderr +Autocache # hash randomization +Beagle # depends on term::readline::perl +Beam-Wire-Moose # broken +Bio-MAGETAB # pod coverage fail and possibly hash randomization +Bio_AssemblyImprovement # broken +BPM-Engine # incorrect deps +Business-RO-CNP # broken +Business-UPS-Tracking # given is experimental +Cache-Profile # broken +Catalyst-Action-Serialize-Data-Serializer # looks like changes in opcode structure +Catalyst-ActionRole-BuildDBICResult # broken +Catalyst-Authentication-Store-LDAP-AD-Class # pod coverage fail +Catalyst-Controller-AutoAssets # broken +Catalyst-Controller-Resources # broken +Catalyst-Controller-SOAP # broken +Catalyst-Engine-Embeddable # broken +Catalyst-Model-Akismet # broken (fake key no longer works) +Catalyst-Model-FormFu # missing deps +Catalyst-Model-Sedna # deps on Alien-Sedna which doesn't exist +Catalyst-Plugin-Continuation # undeclared dep +Catalyst-Plugin-I18N-DBI # pod coverage fail +Catalyst-Plugin-Session-State-Cookie # broken +Catalyst-Plugin-Session-Store-TestMemcached # dep with corrupt archive +Catalyst-Plugin-SwiffUploaderCookieHack # undeclared dep +Catalyst-TraitFor-Component-ConfigPerSite # broken +Catalyst-TraitFor-Request-PerLanguageDomains # dep on ::State::Cookie +CatalystX-Declare # flaky tests (hash randomization?) +CatalystX-ExtJS-Direct # broken +CatalystX-ExtJS-REST # broken +CatalystX-I18N # dep on ::State::Cookie +CatalystX-MooseComponent # broken +CatalystX-OAuth2 # deps on CatalystX::Test::MockContent, which doesn't exist +CatalystX-SimpleLogin # broken +CatalystX-Usul # proc::processtable doesn't load +Chart-OFC2 # coerce without a coercion +Cheater # parse::randgen is broken +CHI-Driver-SharedMem # hash randomization +Class-OWL # uses CMOP::Class without loading cmop +CloudApp-REST # pod coverage fail +Cogwheel # uses ancient moose apis +Config-Model # broken +Config-Model-Backend-Augeas # deps on Config::Model +Config-Model-OpenSsh # deps on Config::Model +Constructible # GD::SVG is a broken dist +Constructible-Maxima # GD::SVG is a broken dist +Coro-Amazon-SimpleDB # amazon::simpledb::client doesn't exist +CPAN-Digger # requires DBD::SQLite +CPAN-Source # missing deps +Data-AMF # missing dep on YAML +Data-Apache-mod_status # invalid characters in type name +Data-Edit # dist is missing some modules +Data-Feed # broken (only sometimes?) +Data-Keys # hash randomization +Data-PackageName # broken +Data-Pensieve # missing deps +Data-Pipeline # uses ancient moose apis +Data-SCORM # pod coverage fail +Data-Valve # for qw() +DayDayUp # MojoX-Fixup-XHTML doesn't exist +DBICx-Modeler-Generator # broken (weirdly) +DBIx-Class-FormTools # hash randomization +DBIx-NoSQL-Store-Manager # flaky tests (hash randomization?) +DBIx-SchemaChecksum # broken +Debian-Apt-PM # configure time failures +Devel-Events # broken (role conflict) +Dist-Zilla-Deb # pod coverage fail +Dist-Zilla-Plugin-ChangelogFromGit-Debian # git::repository is broken +Dist-Zilla-Plugin-CheckChangesHasContent # broken +Dist-Zilla-Plugin-Git # tests fail when run in a temp dir +Dist-Zilla-Plugin-LaunchpadPPA # depends on Dpkg::Changelog::Parse which doesn't exist +Dist-Zilla-Plugin-PerlTidy # expects to find dzil in the path +Dist-Zilla-Plugin-Pinto-Add # deps on Pinto::Common +Dist-Zilla-Plugin-ProgCriticTests # broken +Dist-Zilla-Plugin-Test-ReportPrereqs # broken +DustyDB # uses old moose apis +Dwimmer # broken +ElasticSearchX-Model # hash randomization +Facebook-Graph # broken +FCGI-Engine # runs scripts without using $^X +Fedora-Bugzilla # deps on nonexistent things +Fey-Loader # broken +FFmpeg-Thumbnail # undeclared dep +File-Corresponding # broken +File-DataClass # XML::DTD is a broken dist +File-Stat-Moose # old moose apis +File-Tail-Dir # intermittent fails (i think) +FilmAffinity-UserRating # hash randomization +Finance-Bank-SentinelBenefits-Csv401kConverter # hash randomization +Form-Factory # uses old moose apis +Form-Sensible # broken +FormValidator-Nested # broken +Frost # broken +Games-Dice-Loaded # flaky tests +Geometry-Primitive # coerce with no coercion +Gideon # broken +Git-PurePerl # for qw() +Git-Release # undeclared dep on Mo +Github-Score # broken tests +Gitalist # broken +GOBO # coerce with no coercion +Google-AJAX-Library # hash randomization +Google-Chart # recreating type constraints +Google-Spreadsheet-Agent # pod::coverage fail +Graph-Similarity # perlcritic fail +Hailo # given/when is experimental +Hessian-Translator # perlcritic fail +Hobocamp # configure_requires needs EU::CChecker +Horris # App::Horris isn't on cpan +HPPPM-Demand-Management # pod::coverage fail +HTML-Element-Replacer # hash randomization +HTML-FormFu-ExtJS # hash randomization +HTML-FormHandlerX-Field-DateTimeNatural # broken +HTML-FormHandlerX-Field-URI-HTTP # broken +HTML-Grabber # pod::coverage fail +HTML-TreeBuilderX-ASP_NET # broken +HTTP-Balancer # weird issue with proc::processtable +HTTP-Engine # hash randomization +HTTP-Engine-Middleware # missing dep on yaml +Image-Robohash # Graphics::Magick doesn't exist +JavaScript-Framework-jQuery # coerce with no coercion +Jenkins-NotificationListener # missing dep on File::Read +Jifty # Test::WWW::Selenium needs devel::repl +jQuery-Loader # for qw() +JS-YUI-Loader # broken +JSON-RPC-Common # for qw() +JSORB # broken +Jungle # broken +Kamaitachi # pod::coverage fail +KiokuDB-Backend-Files # broken +KiokuDB-Backend-MongoDB # pod fail +LaTeX-TikZ # broken (with moose) +LCFG-Build-PkgSpec # flaky tests (time zones?) +Lingua-Diversity # pod fail +marc-moose # broken (only sometimes?) +Mac-iPhoto-Exif # smartmatch is experimental +Magpie # broken +Mail-Summary-Tools # DT::Format::DateManip is broken +MediaWiki-USERINFO # broken +Metabase-Backend-MongoDB # broken +Metabase-Backend-SQL # broken (I think) +Method-Signatures # doesn't like ANY_MOOSE=Moose +Mildew # Regexp::Grammars is broken on 5.18 +mobirc # http::engine broken +MooseX-App-Cmd-Command-BashComplete # pod fail +MooseX-Attribute-Prototype # uses old moose apis +MooseX-AttributeHelpers # broken +MooseX-Compile # broken +MooseX-DBIC-Scaffold # needs unreleased sql-translator +MooseX-Documenter # broken +MooseX-DOM # "no Moose" unimports confess +MooseX-Error-Exception-Class # metaclass compat breakage +MooseX-FSM # broken +MooseX-Getopt-Usage # missing dep on Test::Class +MooseX-GTIN # broken (under jenkins, at least) +MooseX-InlineTypes # coerce without coercion +MooseX-Meta-Attribute-Index # old moose apis +MooseX-Meta-Attribute-Lvalue # old moose apis +MooseX-Net-API # hash randomization +MooseX-Q4MLog # Queue::Q4MLog is broken +MooseX-Role-XMLRPC-Client # requires LWP::Protocol::http which requires libssl +MooseX-Scaffold # broken +MooseX-Semantic # hash randomization +MooseX-Struct # ancient moose apis +MooseX-TrackDirty-Attributes # broken +MooseX-Types-Parameterizable # broken +MooseX-Types-Set-Object # coerce without coercion +MooseX-Validation-Doctypes # _process_isa_option +MooseX-WithCache # broken +MouseX-Types # broken (with moose) +MooseX-XSAccessor # coerce without coercion, etc +MySQL-Util # pod-coverage fail +Mvalve # for qw() +Nagios-Passive # broken +Net-APNS # broken (with moose) +Net-FluidDB # broken +Net-Fluidinfo # broken +Net-FreshBooks-API # broken +Net-Google-Blogger # broken +Net-Google-FederatedLogin # broken +Net-Google-PicasaWeb # broken +NetHack-Item # NH::Monster::Spoiler is broken +NetHack-Monster-Spoiler # broken (MX::CA issues) +Net-HTTP-API # hash randomization +Net-HTTP-Factual # broken +Net-ISC-DHCPd # hash randomization +Net-Jabber-Bot # broken +Net-Journyx # broken +Net-Magrathea # pod fail +Net-Mollom # broken +Net-Parliament # broken +Net-Plurk # broken +Net-Rexster-Client # pod fail +Net-SSLeay-OO # broken +Net-StackExchange # broken +Norma # fails when trying to write to a read-only SQLite db file under jenkins, also fails when run manually +NSMS-API # pod fail +ODG-Record # Test::Benchmark broken +OpenXML-Properties # incorrect deps +Orochi # for qw() +Parallel-QueueWorker # flaky test (forking issues) +Parse-CPAN-Perms # flaky tests (hash randomization?) +PDF-TableX # for qw() +Perlbal-Control # proc::processtable doesn't load +Pg-BulkCopy # hardcodes /usr/bin/perl +Pinto-Common # broken +Pinto-Remove # deps on Pinto::Common +Pinto-Server # deps on Pinto::Common +Plack-Middleware-Image-Scale # Image::Scale is broken +Pod-Parser-I18N # missing dep on Data::Localize +POE-Component-CPAN-Mirror-Multiplexer # broken +POE-Component-DirWatch # intermittent failures +POE-Component-DirWatch-Object # intermittent failures +POE-Component-ResourcePool # broken +POE-Component-Server-PSGI # broken deps +POE-Component-Server-SimpleHTTP-PreFork # broken deps +Poet # missing dep on Log::Any::Adapter::Log4perl +POEx-ProxySession # broken deps +POEx-PubSub # broken deps +POEx-WorkerPool # broken deps +PostScript-ScheduleGrid-XMLTV # XMLTV doesn't exist +PRANG # broken +Prophet # depends on term::readline::perl +Queue-Leaky # broken +Queue-Q4M # for qw() +RackMan # kwalitee fail +Railsish # dep on nonexistent dist +RDF-Helper # for qw() +RDF-Server # "no Moose" unimports confess +Reaction # signatures is broken +Reflexive-Role-DataMover # broken (reflex::role changes?) +Reflexive-Role-TCPServer # broken (reflex::role changes?) +Reflexive-Stream-Filtering # broken +RPC-Any # broken +RPM-Spec # coerce with no coercion +RT-ClientX-GrabBugs # scalar::does doesn't specify deps properly +RTDevSys # pod fail +Scene-Graph # has '+attr' in roles +Scrappy # hash randomization +Server-Control # proc::processtable doesn't load +Shipment # locale::subcountry is broken +Silki # image::magick is broken +SilkiX-Converter-Kwiki # file::mimeinfo expects (?-xism: +SIOC # for qw() +Sloth # rest::utils is broken +Sque # couldn't fork server for testing +SRS-EPP-Proxy # depends on xml::epp +String-Blender # broken +Sys-RotateBackup # broken +System-Wrapper # pod coverage fail +TAEB # broken +TAP-Formatter-Bamboo # hash randomization +TAP-Formatter-JUnit # hash randomization +Tail-Tool # Getopt::Alt doesn't exist +Tapper-Action # broken +Tapper-CLI # sys::info::driver::linux is broken +Tapper-Installer # sys::info::driver::linux is broken +Tapper-MCP-MessageReceiver # sys::info::driver::linux is broken +Tapper-Reports-API # sys::info::driver::linux is broken +Tapper-Reports-Receiver # flaky tests (timeouts) +Tapper-Testplan # sys::info::driver::linux is broken +Telephone-Mnemonic-US # rpm-build-perl is broken +Template-Plugin-Heritable # weird dep issues (not test::dm related) +Test-A8N # broken +Test-Daily # configure errors +Test-HTML-Spelling # broken +Test-Moose-More # coerce without coercion +Test-Pockito # broken +Test-WWW-Selenium-More # Test::WWW::Selenium needs devel::repl +Text-Clevery # broken +Text-TEI-Collate # pod fail +Text-Zilla # broken +Thorium # depends on Hobocamp +TPath # regexp::grammars is broken on 5.18 +TPath-Forester-File # regexp::grammars is broken on 5.18 +TPath-Forester-Ref # regexp::grammars is broken on 5.18 +TryCatch-Error # broken +UnRTF # broken +VCI # for qw() +Verby # deps on poe::component::resourcepool +W3C-SOAP # broken +W3C-SOAP-WADL # broken +Weather-TW # missing dep on Mojo::DOM +Web-API-Mapper # broken +WebNano-Controller-CRUD # broken +WebService-E4SE # pod coverage fail +WebService-Embedly # broken +Webservice-InterMine # hash randomization +WebService-LOC-CongRec # broken +WebService-Mirth # broken +WebService-Uptrack # perlcritic fail +WebService-Yes24 # broken +WiX3 # broken +WSDL-Compile # flaky tests (hash randomization?) +WWW-3Taps-API # pod fail +WWW-Alltop # XML::SimpleObject configure fail +WWW-Comix # uses ancient Moose::Policy stuff +WWW-DataWiki # broken +WWW-EFA # pod fail +WWW-Fandango # bad dist +WWW-FMyLife # broken +WWW-Google-Moderator # hash randomization +WWW-Google-Places # hash randomization +WWW-Mechanize-Cached # tries to read from wrong build dir? +WWW-Mechanize-Query # wrong deps (Mojo::DOM vs Mojo::Dom) +WWW-Metalgate # Cache is broken +WWW-Scramble # pod::coverage fail +WWW-SearchWikipedia # hash randomization +WWW-Sitemapper # broken +WWW-StaticBlog # time::sofar is broken +WWW-WebKit # missing configure_req on EU::PkgConfig +WWW-Wookie # kwalitee fail +WWW-Yahoo-Lyrics-JP # broken +XIRCD # undeclared deps +XML-Compare # pod fail +XML-EPP # coerce without coercion +XML-SRS # deps on prang +XML-Writer-Compiler # broken tests +YellowBot-API # pod fail +YUI-Loader # hash randomization +Yukki # git::repository is broken diff --git a/xt/release/00-compile.t b/xt/release/00-compile.t new file mode 100644 index 0000000..cdebec2 --- /dev/null +++ b/xt/release/00-compile.t @@ -0,0 +1,449 @@ +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.053 + +use Test::More 0.94; + +plan tests => 367 + ($ENV{AUTHOR_TESTING} ? 1 : 0); + +my @module_files = ( + 'Class/MOP.pm', + 'Class/MOP/Class/Immutable/Trait.pm', + 'Class/MOP/Deprecated.pm', + 'Class/MOP/Instance.pm', + 'Class/MOP/Method.pm', + 'Class/MOP/Method/Generated.pm', + 'Class/MOP/Method/Meta.pm', + 'Class/MOP/MiniTrait.pm', + 'Class/MOP/Mixin.pm', + 'Class/MOP/Mixin/AttributeCore.pm', + 'Class/MOP/Mixin/HasMethods.pm', + 'Class/MOP/Mixin/HasOverloads.pm', + 'Class/MOP/Object.pm', + 'Class/MOP/Overload.pm', + 'Moose.pm', + 'Moose/Conflicts.pm', + 'Moose/Deprecated.pm', + 'Moose/Exception.pm', + 'Moose/Exception/AccessorMustReadWrite.pm', + 'Moose/Exception/AddParameterizableTypeTakesParameterizableType.pm', + 'Moose/Exception/AddRoleTakesAMooseMetaRoleInstance.pm', + 'Moose/Exception/AddRoleToARoleTakesAMooseMetaRole.pm', + 'Moose/Exception/ApplyTakesABlessedInstance.pm', + 'Moose/Exception/AttachToClassNeedsAClassMOPClassInstanceOrASubclass.pm', + 'Moose/Exception/AttributeConflictInRoles.pm', + 'Moose/Exception/AttributeConflictInSummation.pm', + 'Moose/Exception/AttributeExtensionIsNotSupportedInRoles.pm', + 'Moose/Exception/AttributeIsRequired.pm', + 'Moose/Exception/AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass.pm', + 'Moose/Exception/AttributeNamesDoNotMatch.pm', + 'Moose/Exception/AttributeValueIsNotAnObject.pm', + 'Moose/Exception/AttributeValueIsNotDefined.pm', + 'Moose/Exception/AutoDeRefNeedsArrayRefOrHashRef.pm', + 'Moose/Exception/BadOptionFormat.pm', + 'Moose/Exception/BothBuilderAndDefaultAreNotAllowed.pm', + 'Moose/Exception/BuilderDoesNotExist.pm', + 'Moose/Exception/BuilderMethodNotSupportedForAttribute.pm', + 'Moose/Exception/BuilderMethodNotSupportedForInlineAttribute.pm', + 'Moose/Exception/BuilderMustBeAMethodName.pm', + 'Moose/Exception/CallingMethodOnAnImmutableInstance.pm', + 'Moose/Exception/CallingReadOnlyMethodOnAnImmutableInstance.pm', + 'Moose/Exception/CanExtendOnlyClasses.pm', + 'Moose/Exception/CanOnlyConsumeRole.pm', + 'Moose/Exception/CanOnlyWrapBlessedCode.pm', + 'Moose/Exception/CanReblessOnlyIntoASubclass.pm', + 'Moose/Exception/CanReblessOnlyIntoASuperclass.pm', + 'Moose/Exception/CannotAddAdditionalTypeCoercionsToUnion.pm', + 'Moose/Exception/CannotAddAsAnAttributeToARole.pm', + 'Moose/Exception/CannotApplyBaseClassRolesToRole.pm', + 'Moose/Exception/CannotAssignValueToReadOnlyAccessor.pm', + 'Moose/Exception/CannotAugmentIfLocalMethodPresent.pm', + 'Moose/Exception/CannotAugmentNoSuperMethod.pm', + 'Moose/Exception/CannotAutoDerefWithoutIsa.pm', + 'Moose/Exception/CannotAutoDereferenceTypeConstraint.pm', + 'Moose/Exception/CannotCalculateNativeType.pm', + 'Moose/Exception/CannotCallAnAbstractBaseMethod.pm', + 'Moose/Exception/CannotCallAnAbstractMethod.pm', + 'Moose/Exception/CannotCoerceAWeakRef.pm', + 'Moose/Exception/CannotCoerceAttributeWhichHasNoCoercion.pm', + 'Moose/Exception/CannotCreateHigherOrderTypeWithoutATypeParameter.pm', + 'Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresent.pm', + 'Moose/Exception/CannotCreateMethodAliasLocalMethodIsPresentInClass.pm', + 'Moose/Exception/CannotDelegateLocalMethodIsPresent.pm', + 'Moose/Exception/CannotDelegateWithoutIsa.pm', + 'Moose/Exception/CannotFindDelegateMetaclass.pm', + 'Moose/Exception/CannotFindType.pm', + 'Moose/Exception/CannotFindTypeGivenToMatchOnType.pm', + 'Moose/Exception/CannotFixMetaclassCompatibility.pm', + 'Moose/Exception/CannotGenerateInlineConstraint.pm', + 'Moose/Exception/CannotInitializeMooseMetaRoleComposite.pm', + 'Moose/Exception/CannotInlineTypeConstraintCheck.pm', + 'Moose/Exception/CannotLocatePackageInINC.pm', + 'Moose/Exception/CannotMakeMetaclassCompatible.pm', + 'Moose/Exception/CannotOverrideALocalMethod.pm', + 'Moose/Exception/CannotOverrideBodyOfMetaMethods.pm', + 'Moose/Exception/CannotOverrideLocalMethodIsPresent.pm', + 'Moose/Exception/CannotOverrideNoSuperMethod.pm', + 'Moose/Exception/CannotRegisterUnnamedTypeConstraint.pm', + 'Moose/Exception/CannotUseLazyBuildAndDefaultSimultaneously.pm', + 'Moose/Exception/CircularReferenceInAlso.pm', + 'Moose/Exception/ClassDoesNotHaveInitMeta.pm', + 'Moose/Exception/ClassDoesTheExcludedRole.pm', + 'Moose/Exception/ClassNamesDoNotMatch.pm', + 'Moose/Exception/CloneObjectExpectsAnInstanceOfMetaclass.pm', + 'Moose/Exception/CodeBlockMustBeACodeRef.pm', + 'Moose/Exception/CoercingWithoutCoercions.pm', + 'Moose/Exception/CoercionAlreadyExists.pm', + 'Moose/Exception/CoercionNeedsTypeConstraint.pm', + 'Moose/Exception/ConflictDetectedInCheckRoleExclusions.pm', + 'Moose/Exception/ConflictDetectedInCheckRoleExclusionsInToClass.pm', + 'Moose/Exception/ConstructClassInstanceTakesPackageName.pm', + 'Moose/Exception/CouldNotCreateMethod.pm', + 'Moose/Exception/CouldNotCreateWriter.pm', + 'Moose/Exception/CouldNotEvalConstructor.pm', + 'Moose/Exception/CouldNotEvalDestructor.pm', + 'Moose/Exception/CouldNotFindTypeConstraintToCoerceFrom.pm', + 'Moose/Exception/CouldNotGenerateInlineAttributeMethod.pm', + 'Moose/Exception/CouldNotLocateTypeConstraintForUnion.pm', + 'Moose/Exception/CouldNotParseType.pm', + 'Moose/Exception/CreateMOPClassTakesArrayRefOfAttributes.pm', + 'Moose/Exception/CreateMOPClassTakesArrayRefOfSuperclasses.pm', + 'Moose/Exception/CreateMOPClassTakesHashRefOfMethods.pm', + 'Moose/Exception/CreateTakesArrayRefOfRoles.pm', + 'Moose/Exception/CreateTakesHashRefOfAttributes.pm', + 'Moose/Exception/CreateTakesHashRefOfMethods.pm', + 'Moose/Exception/DefaultToMatchOnTypeMustBeCodeRef.pm', + 'Moose/Exception/DelegationToAClassWhichIsNotLoaded.pm', + 'Moose/Exception/DelegationToARoleWhichIsNotLoaded.pm', + 'Moose/Exception/DelegationToATypeWhichIsNotAClass.pm', + 'Moose/Exception/DoesRequiresRoleName.pm', + 'Moose/Exception/EnumCalledWithAnArrayRefAndAdditionalArgs.pm', + 'Moose/Exception/EnumValuesMustBeString.pm', + 'Moose/Exception/ExtendsMissingArgs.pm', + 'Moose/Exception/HandlesMustBeAHashRef.pm', + 'Moose/Exception/IllegalInheritedOptions.pm', + 'Moose/Exception/IllegalMethodTypeToAddMethodModifier.pm', + 'Moose/Exception/IncompatibleMetaclassOfSuperclass.pm', + 'Moose/Exception/InitMetaRequiresClass.pm', + 'Moose/Exception/InitializeTakesUnBlessedPackageName.pm', + 'Moose/Exception/InstanceBlessedIntoWrongClass.pm', + 'Moose/Exception/InstanceMustBeABlessedReference.pm', + 'Moose/Exception/InvalidArgPassedToMooseUtilMetaRole.pm', + 'Moose/Exception/InvalidArgumentToMethod.pm', + 'Moose/Exception/InvalidArgumentsToTraitAliases.pm', + 'Moose/Exception/InvalidBaseTypeGivenToCreateParameterizedTypeConstraint.pm', + 'Moose/Exception/InvalidHandleValue.pm', + 'Moose/Exception/InvalidHasProvidedInARole.pm', + 'Moose/Exception/InvalidNameForType.pm', + 'Moose/Exception/InvalidOverloadOperator.pm', + 'Moose/Exception/InvalidRoleApplication.pm', + 'Moose/Exception/InvalidTypeConstraint.pm', + 'Moose/Exception/InvalidTypeGivenToCreateParameterizedTypeConstraint.pm', + 'Moose/Exception/InvalidValueForIs.pm', + 'Moose/Exception/IsaDoesNotDoTheRole.pm', + 'Moose/Exception/IsaLacksDoesMethod.pm', + 'Moose/Exception/LazyAttributeNeedsADefault.pm', + 'Moose/Exception/Legacy.pm', + 'Moose/Exception/MOPAttributeNewNeedsAttributeName.pm', + 'Moose/Exception/MatchActionMustBeACodeRef.pm', + 'Moose/Exception/MessageParameterMustBeCodeRef.pm', + 'Moose/Exception/MetaclassIsAClassNotASubclassOfGivenMetaclass.pm', + 'Moose/Exception/MetaclassIsARoleNotASubclassOfGivenMetaclass.pm', + 'Moose/Exception/MetaclassIsNotASubclassOfGivenMetaclass.pm', + 'Moose/Exception/MetaclassMustBeASubclassOfMooseMetaClass.pm', + 'Moose/Exception/MetaclassMustBeASubclassOfMooseMetaRole.pm', + 'Moose/Exception/MetaclassMustBeDerivedFromClassMOPClass.pm', + 'Moose/Exception/MetaclassNotLoaded.pm', + 'Moose/Exception/MetaclassTypeIncompatible.pm', + 'Moose/Exception/MethodExpectedAMetaclassObject.pm', + 'Moose/Exception/MethodExpectsFewerArgs.pm', + 'Moose/Exception/MethodExpectsMoreArgs.pm', + 'Moose/Exception/MethodModifierNeedsMethodName.pm', + 'Moose/Exception/MethodNameConflictInRoles.pm', + 'Moose/Exception/MethodNameNotFoundInInheritanceHierarchy.pm', + 'Moose/Exception/MethodNameNotGiven.pm', + 'Moose/Exception/MustDefineAMethodName.pm', + 'Moose/Exception/MustDefineAnAttributeName.pm', + 'Moose/Exception/MustDefineAnOverloadOperator.pm', + 'Moose/Exception/MustHaveAtLeastOneValueToEnumerate.pm', + 'Moose/Exception/MustPassAHashOfOptions.pm', + 'Moose/Exception/MustPassAMooseMetaRoleInstanceOrSubclass.pm', + 'Moose/Exception/MustPassAPackageNameOrAnExistingClassMOPPackageInstance.pm', + 'Moose/Exception/MustPassEvenNumberOfArguments.pm', + 'Moose/Exception/MustPassEvenNumberOfAttributeOptions.pm', + 'Moose/Exception/MustProvideANameForTheAttribute.pm', + 'Moose/Exception/MustSpecifyAtleastOneMethod.pm', + 'Moose/Exception/MustSpecifyAtleastOneRole.pm', + 'Moose/Exception/MustSpecifyAtleastOneRoleToApplicant.pm', + 'Moose/Exception/MustSupplyAClassMOPAttributeInstance.pm', + 'Moose/Exception/MustSupplyADelegateToMethod.pm', + 'Moose/Exception/MustSupplyAMetaclass.pm', + 'Moose/Exception/MustSupplyAMooseMetaAttributeInstance.pm', + 'Moose/Exception/MustSupplyAnAccessorTypeToConstructWith.pm', + 'Moose/Exception/MustSupplyAnAttributeToConstructWith.pm', + 'Moose/Exception/MustSupplyArrayRefAsCurriedArguments.pm', + 'Moose/Exception/MustSupplyPackageNameAndName.pm', + 'Moose/Exception/NeedsTypeConstraintUnionForTypeCoercionUnion.pm', + 'Moose/Exception/NeitherAttributeNorAttributeNameIsGiven.pm', + 'Moose/Exception/NeitherClassNorClassNameIsGiven.pm', + 'Moose/Exception/NeitherRoleNorRoleNameIsGiven.pm', + 'Moose/Exception/NeitherTypeNorTypeNameIsGiven.pm', + 'Moose/Exception/NoAttributeFoundInSuperClass.pm', + 'Moose/Exception/NoBodyToInitializeInAnAbstractBaseClass.pm', + 'Moose/Exception/NoCasesMatched.pm', + 'Moose/Exception/NoConstraintCheckForTypeConstraint.pm', + 'Moose/Exception/NoDestructorClassSpecified.pm', + 'Moose/Exception/NoImmutableTraitSpecifiedForClass.pm', + 'Moose/Exception/NoParentGivenToSubtype.pm', + 'Moose/Exception/OnlyInstancesCanBeCloned.pm', + 'Moose/Exception/OperatorIsRequired.pm', + 'Moose/Exception/OverloadConflictInSummation.pm', + 'Moose/Exception/OverloadRequiresAMetaClass.pm', + 'Moose/Exception/OverloadRequiresAMetaMethod.pm', + 'Moose/Exception/OverloadRequiresAMetaOverload.pm', + 'Moose/Exception/OverloadRequiresAMethodNameOrCoderef.pm', + 'Moose/Exception/OverloadRequiresAnOperator.pm', + 'Moose/Exception/OverloadRequiresNamesForCoderef.pm', + 'Moose/Exception/OverrideConflictInComposition.pm', + 'Moose/Exception/OverrideConflictInSummation.pm', + 'Moose/Exception/PackageDoesNotUseMooseExporter.pm', + 'Moose/Exception/PackageNameAndNameParamsNotGivenToWrap.pm', + 'Moose/Exception/PackagesAndModulesAreNotCachable.pm', + 'Moose/Exception/ParameterIsNotSubtypeOfParent.pm', + 'Moose/Exception/ReferencesAreNotAllowedAsDefault.pm', + 'Moose/Exception/RequiredAttributeLacksInitialization.pm', + 'Moose/Exception/RequiredAttributeNeedsADefault.pm', + 'Moose/Exception/RequiredMethodsImportedByClass.pm', + 'Moose/Exception/RequiredMethodsNotImplementedByClass.pm', + 'Moose/Exception/Role/Attribute.pm', + 'Moose/Exception/Role/AttributeName.pm', + 'Moose/Exception/Role/Class.pm', + 'Moose/Exception/Role/EitherAttributeOrAttributeName.pm', + 'Moose/Exception/Role/Instance.pm', + 'Moose/Exception/Role/InstanceClass.pm', + 'Moose/Exception/Role/InvalidAttributeOptions.pm', + 'Moose/Exception/Role/Method.pm', + 'Moose/Exception/Role/ParamsHash.pm', + 'Moose/Exception/Role/Role.pm', + 'Moose/Exception/Role/RoleForCreate.pm', + 'Moose/Exception/Role/RoleForCreateMOPClass.pm', + 'Moose/Exception/Role/TypeConstraint.pm', + 'Moose/Exception/RoleDoesTheExcludedRole.pm', + 'Moose/Exception/RoleExclusionConflict.pm', + 'Moose/Exception/RoleNameRequired.pm', + 'Moose/Exception/RoleNameRequiredForMooseMetaRole.pm', + 'Moose/Exception/RolesDoNotSupportAugment.pm', + 'Moose/Exception/RolesDoNotSupportExtends.pm', + 'Moose/Exception/RolesDoNotSupportInner.pm', + 'Moose/Exception/RolesDoNotSupportRegexReferencesForMethodModifiers.pm', + 'Moose/Exception/RolesInCreateTakesAnArrayRef.pm', + 'Moose/Exception/RolesListMustBeInstancesOfMooseMetaRole.pm', + 'Moose/Exception/SingleParamsToNewMustBeHashRef.pm', + 'Moose/Exception/TriggerMustBeACodeRef.pm', + 'Moose/Exception/TypeConstraintCannotBeUsedForAParameterizableType.pm', + 'Moose/Exception/TypeConstraintIsAlreadyCreated.pm', + 'Moose/Exception/TypeParameterMustBeMooseMetaType.pm', + 'Moose/Exception/UnableToCanonicalizeHandles.pm', + 'Moose/Exception/UnableToCanonicalizeNonRolePackage.pm', + 'Moose/Exception/UnableToRecognizeDelegateMetaclass.pm', + 'Moose/Exception/UndefinedHashKeysPassedToMethod.pm', + 'Moose/Exception/UnionCalledWithAnArrayRefAndAdditionalArgs.pm', + 'Moose/Exception/UnionTakesAtleastTwoTypeNames.pm', + 'Moose/Exception/ValidationFailedForInlineTypeConstraint.pm', + 'Moose/Exception/ValidationFailedForTypeConstraint.pm', + 'Moose/Exception/WrapTakesACodeRefToBless.pm', + 'Moose/Exception/WrongTypeConstraintGiven.pm', + 'Moose/Exporter.pm', + 'Moose/Meta/Attribute/Native/Trait.pm', + 'Moose/Meta/Attribute/Native/Trait/Array.pm', + 'Moose/Meta/Attribute/Native/Trait/Bool.pm', + 'Moose/Meta/Attribute/Native/Trait/Code.pm', + 'Moose/Meta/Attribute/Native/Trait/Counter.pm', + 'Moose/Meta/Attribute/Native/Trait/Hash.pm', + 'Moose/Meta/Attribute/Native/Trait/Number.pm', + 'Moose/Meta/Attribute/Native/Trait/String.pm', + 'Moose/Meta/Class.pm', + 'Moose/Meta/Class/Immutable/Trait.pm', + 'Moose/Meta/Instance.pm', + 'Moose/Meta/Method.pm', + 'Moose/Meta/Method/Accessor.pm', + 'Moose/Meta/Method/Accessor/Native.pm', + 'Moose/Meta/Method/Accessor/Native/Array.pm', + 'Moose/Meta/Method/Accessor/Native/Array/Writer.pm', + 'Moose/Meta/Method/Accessor/Native/Array/accessor.pm', + 'Moose/Meta/Method/Accessor/Native/Array/clear.pm', + 'Moose/Meta/Method/Accessor/Native/Array/count.pm', + 'Moose/Meta/Method/Accessor/Native/Array/delete.pm', + 'Moose/Meta/Method/Accessor/Native/Array/elements.pm', + 'Moose/Meta/Method/Accessor/Native/Array/first.pm', + 'Moose/Meta/Method/Accessor/Native/Array/first_index.pm', + 'Moose/Meta/Method/Accessor/Native/Array/get.pm', + 'Moose/Meta/Method/Accessor/Native/Array/grep.pm', + 'Moose/Meta/Method/Accessor/Native/Array/insert.pm', + 'Moose/Meta/Method/Accessor/Native/Array/is_empty.pm', + 'Moose/Meta/Method/Accessor/Native/Array/join.pm', + 'Moose/Meta/Method/Accessor/Native/Array/map.pm', + 'Moose/Meta/Method/Accessor/Native/Array/natatime.pm', + 'Moose/Meta/Method/Accessor/Native/Array/pop.pm', + 'Moose/Meta/Method/Accessor/Native/Array/push.pm', + 'Moose/Meta/Method/Accessor/Native/Array/reduce.pm', + 'Moose/Meta/Method/Accessor/Native/Array/set.pm', + 'Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm', + 'Moose/Meta/Method/Accessor/Native/Array/shift.pm', + 'Moose/Meta/Method/Accessor/Native/Array/shuffle.pm', + 'Moose/Meta/Method/Accessor/Native/Array/sort.pm', + 'Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm', + 'Moose/Meta/Method/Accessor/Native/Array/splice.pm', + 'Moose/Meta/Method/Accessor/Native/Array/uniq.pm', + 'Moose/Meta/Method/Accessor/Native/Array/unshift.pm', + 'Moose/Meta/Method/Accessor/Native/Bool/not.pm', + 'Moose/Meta/Method/Accessor/Native/Bool/set.pm', + 'Moose/Meta/Method/Accessor/Native/Bool/toggle.pm', + 'Moose/Meta/Method/Accessor/Native/Bool/unset.pm', + 'Moose/Meta/Method/Accessor/Native/Code/execute.pm', + 'Moose/Meta/Method/Accessor/Native/Code/execute_method.pm', + 'Moose/Meta/Method/Accessor/Native/Collection.pm', + 'Moose/Meta/Method/Accessor/Native/Counter/Writer.pm', + 'Moose/Meta/Method/Accessor/Native/Counter/dec.pm', + 'Moose/Meta/Method/Accessor/Native/Counter/inc.pm', + 'Moose/Meta/Method/Accessor/Native/Counter/reset.pm', + 'Moose/Meta/Method/Accessor/Native/Counter/set.pm', + 'Moose/Meta/Method/Accessor/Native/Hash.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/Writer.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/accessor.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/clear.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/count.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/defined.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/delete.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/elements.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/exists.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/get.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/keys.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/kv.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/set.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm', + 'Moose/Meta/Method/Accessor/Native/Hash/values.pm', + 'Moose/Meta/Method/Accessor/Native/Number/abs.pm', + 'Moose/Meta/Method/Accessor/Native/Number/add.pm', + 'Moose/Meta/Method/Accessor/Native/Number/div.pm', + 'Moose/Meta/Method/Accessor/Native/Number/mod.pm', + 'Moose/Meta/Method/Accessor/Native/Number/mul.pm', + 'Moose/Meta/Method/Accessor/Native/Number/set.pm', + 'Moose/Meta/Method/Accessor/Native/Number/sub.pm', + 'Moose/Meta/Method/Accessor/Native/Reader.pm', + 'Moose/Meta/Method/Accessor/Native/String/append.pm', + 'Moose/Meta/Method/Accessor/Native/String/chomp.pm', + 'Moose/Meta/Method/Accessor/Native/String/chop.pm', + 'Moose/Meta/Method/Accessor/Native/String/clear.pm', + 'Moose/Meta/Method/Accessor/Native/String/inc.pm', + 'Moose/Meta/Method/Accessor/Native/String/length.pm', + 'Moose/Meta/Method/Accessor/Native/String/match.pm', + 'Moose/Meta/Method/Accessor/Native/String/prepend.pm', + 'Moose/Meta/Method/Accessor/Native/String/replace.pm', + 'Moose/Meta/Method/Accessor/Native/String/substr.pm', + 'Moose/Meta/Method/Accessor/Native/Writer.pm', + 'Moose/Meta/Method/Augmented.pm', + 'Moose/Meta/Method/Constructor.pm', + 'Moose/Meta/Method/Delegation.pm', + 'Moose/Meta/Method/Destructor.pm', + 'Moose/Meta/Method/Meta.pm', + 'Moose/Meta/Method/Overridden.pm', + 'Moose/Meta/Object/Trait.pm', + 'Moose/Meta/Role.pm', + 'Moose/Meta/Role/Application.pm', + 'Moose/Meta/Role/Application/RoleSummation.pm', + 'Moose/Meta/Role/Application/ToClass.pm', + 'Moose/Meta/Role/Application/ToInstance.pm', + 'Moose/Meta/Role/Application/ToRole.pm', + 'Moose/Meta/Role/Composite.pm', + 'Moose/Meta/Role/Method.pm', + 'Moose/Meta/Role/Method/Conflicting.pm', + 'Moose/Meta/Role/Method/Required.pm', + 'Moose/Meta/TypeCoercion.pm', + 'Moose/Meta/TypeCoercion/Union.pm', + 'Moose/Meta/TypeConstraint.pm', + 'Moose/Meta/TypeConstraint/Registry.pm', + 'Moose/Object.pm', + 'Moose/Role.pm', + 'Moose/Util.pm', + 'Moose/Util/MetaRole.pm', + 'Moose/Util/TypeConstraints.pm', + 'Moose/Util/TypeConstraints/Builtins.pm', + 'Test/Moose.pm', + 'metaclass.pm', + 'oose.pm' +); + +my @scripts = ( + 'bin/moose-outdated' +); + +# no fake home requested + +my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L<perlfaq8/How can I capture STDERR from an external command?> + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { blib->VERSION('1.01') }; + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + +foreach my $file (@scripts) +{ SKIP: { + open my $fh, '<', $file or warn("Unable to open $file: $!"), next; + my $line = <$fh>; + + close $fh and skip("$file isn't perl", 1) unless $line =~ /^#!\s*(?:\S*perl\S*)((?:\s+-\w*)*)(?:\s*#.*)?$/; + my @flags = $1 ? split(' ', $1) : (); + + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, @flags, '-c', $file); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$file compiled ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { blib->VERSION('1.01') }; + + # in older perls, -c output is simply the file portion of the path being tested + if (@_warnings = grep { !/\bsyntax OK$/ } + grep { chomp; $_ ne (File::Spec->splitpath($file))[2] } @_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} } + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', explain(\@warnings) if $ENV{AUTHOR_TESTING}; + +BAIL_OUT("Compilation problems") if !Test::More->builder->is_passing; diff --git a/xt/release/cpan-changes.t b/xt/release/cpan-changes.t new file mode 100644 index 0000000..8e6e413 --- /dev/null +++ b/xt/release/cpan-changes.t @@ -0,0 +1,11 @@ +#!perl + +use strict; +use warnings; + +use Test::More 0.96 tests => 2; +use_ok('Test::CPAN::Changes'); +subtest 'changes_ok' => sub { + changes_file_ok('Changes'); +}; +done_testing(); diff --git a/xt/release/distmeta.t b/xt/release/distmeta.t new file mode 100644 index 0000000..c2280dc --- /dev/null +++ b/xt/release/distmeta.t @@ -0,0 +1,6 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::MetaTests. + +use Test::CPAN::Meta; + +meta_yaml_ok(); diff --git a/xt/release/kwalitee.t b/xt/release/kwalitee.t new file mode 100644 index 0000000..8d6f3c6 --- /dev/null +++ b/xt/release/kwalitee.t @@ -0,0 +1,9 @@ +# this test was generated with Dist::Zilla::Plugin::Test::Kwalitee 2.11 +use strict; +use warnings; +use Test::More 0.88; +use Test::Kwalitee 1.21 'kwalitee_ok'; + +kwalitee_ok( qw( -use_strict ) ); + +done_testing; diff --git a/xt/release/mojibake.t b/xt/release/mojibake.t new file mode 100644 index 0000000..390c632 --- /dev/null +++ b/xt/release/mojibake.t @@ -0,0 +1,12 @@ +#!perl + +use strict; +use warnings qw(all); + +use Test::More; + +## no critic (ProhibitStringyEval, RequireCheckingReturnValueOfEval) +eval q(use Test::Mojibake); +plan skip_all => q(Test::Mojibake required for source encoding testing) if $@; + +all_files_encoding_ok(); diff --git a/xt/release/pod-syntax.t b/xt/release/pod-syntax.t new file mode 100644 index 0000000..f0468f1 --- /dev/null +++ b/xt/release/pod-syntax.t @@ -0,0 +1,6 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. +use Test::More; +use Test::Pod 1.41; + +all_pod_files_ok(); |