From 7187a40ac7d447568920e29905891708cce2953d Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 24 2020 10:31:58 +0000 Subject: perl-Moo-2.003004 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..cb9034a --- /dev/null +++ b/Changes @@ -0,0 +1,586 @@ +Revision history for Moo + +2.003004 - 2017-12-01 + - re-allow stubs for attribute parameters like isa or coerce (RT#123753) + - fix accidentally removed space in coderef error message (GH#33) + - fix test errors with old Carp versions + +2.003003 - 2017-11-16 + - test tweaks + - fix handling of code refs stored directly in the stash (for perl 5.28) + - consider inline packages with constants in them as being loaded + - stubs will be treated as methods that exist when inflating to Moose + - avoid loading overload.pm unless required + +2.003002 - 2017-03-28 + - ensure tarball does not contain SCHILY headers + +2.003001 - 2017-03-06 + - fix +attributes replacing builder subs if parent attribute was defined with + builder => $subref + - fix trigger with a default value and init_arg of undef + +2.003000 - 2016-12-09 + - fix create_class_with_roles being used multiple times with the same packages + - fix edge case with @ISA assignment on perl 5.10.0 + - minor test adjustments + - fix handles on oddly named attributes + - make has options linkable in documentation + - Sub::Quote and Sub::Defer have been split into a separate dist + +2.002005 - 2016-10-31 + - fix accessor extensions that need captured variables for clearers and + predicates. (RT#118453) + - avoid relying on '.' being in @INC in tests + - fix Sub::Quote test when run with perl -C or PERL_UNICODE on perl 5.10 + (RT#117844) + - improved error messages for invalid sub names in Sub::Quote (RT#116416, + RT#117711) + - clarify meta method documentation + - bump Role::Tiny prereq version to get stub in role fix (RT#116674) + +2.002004 - 2016-06-28 + - fixed another case of local functions interfering with generated code. + (RT#115655) + - prevent infinite recursion on some Moose metaclass inflation errors. + +2.002003 - 2016-06-23 + - prevent local functions with same names as core functions from interfering + with generated code (RT#115529) + - Work around nmake bug that corrupts commands that include slashes + (RT#115518) + - Fix tests to work when lexical features are enabled outside of our control + (such as with cperl) + - Fix tests on perl 5.6 + +2.002002 - 2016-06-21 + - fix handling of Carp < 1.12 + +2.002_001 - 2016-06-17 + - added Sub::Quote::sanitize_identifier to generate an identifier from an + arbitrary string. + - Sub::Defer::defer_info is now exportable. + - improved documentation for Sub::Quote. + - fix quoted subs with no_defer ignoring no_install option. (RT#114605) + - internals of Sub::Quote were refactored. + - error message when @ISA changes now includes the location that the + constructor was generated. + - original invoker will be used when calling a non-Moo parent constructor. + (RT#115189) + - added testing for preserving context into quote_sub subs. (RT#114511) + - quote_sub context options will be used even when zero. (RT#114512) + - Sub::Defer::defer_sub gained attributes option to specify sub attributes. + - Sub::Quote::quote_sub gained attributes option to specify sub attributes. + +2.002_000 - 2016-05-18 + - Use Carp::croak rather than die to improve reported error locations + (RT#109844, RT#109632, RT#102622) + - removed Method::Inliner module. It was never intended to ship with Moo, + and was undocumented, untested, and unused on CPAN. + - require Role::Tiny 2.000002 for fixes to method modifiers being applied + via multiple role composition paths (RT#106668) + - Delay loading Class::Method::Modifiers until we actually need it + - Fix an explosion that could happen if meta inflation was attempted part way + through Moo's bootstrapping process, which was possible via a + CORE::GLOBAL::bless override (RT#113743) + - Accessor subs will be generated immediately, rather than being partially + deferred. The deferal added extra sub layers and the delayed compilation + didn't provide any real benefit for them. + - Numeric values used as defaults will be inlined as numbers rather than + strings. + - Numerous test cleanups and additional test coverage + - Fixed a typo in Sub::Defer docs (RT#113416) + - Deferred subs (including constructors) will always be named properly, even + if neither Sub::Name nor Sub::Util are available. This improves + compatibility with namespace::autoclean, among other things. Once the sub + is undeferred, it may not be given a correct name if Sub::Name or Sub::Util + aren't available. + +2.001001 - 2016-03-04 + - Fixed order of attribute value being set and trigger running when there is + an isa check present. (RT#112677) + - Corrected LIFECYCLE METHODS to be a head1 section rather than head2. + +2.001000 - 2016-02-29 + * Documentation + - Added documentation for has's ability to accept an arrayref of attribute + names to create with the same options. + - Removed mention that we may not call BUILDARGS, since that behavior was + removed in 2.000002. + - Reorganized documentation of class methods to separate those provided as a + public API (new/does/meta) from those used by Moo in the object lifecycle + (BUILDARGS/FOREIGNBUILDARGS/BUILD/DEMOLISH). + - Updated documentation of most class methods for clarity. + - Updated BUILDARGS documentation to show an around rather than just + overriding. + - Added examples to FOREIGNBUILDARGS and BUILD. + - Added explicit documentation for DOES and meta methods. + + * Fixes + - Fixed grammar in error message when @ISA is changed unexpectedly before + a constructor is fully generated. + - Fixed Moo classes and Sub::Quote subs in packages that are nearly 252 + characters long. + - Fixed Sub::Defer::undefer_package emitting warnings. + - Fixed detection of constructors that have already been inlined. + + * Performance + - The generated code in constructors and setters has had a number of + microoptimizations applied. + - Deferred subs (and quoted subs like some accessors) in roles will be + undefered before copying them to classes. This prevents the need for a + goto on every call that would slow down the subs. + - Fixed Moose inflation code resulting in constructors with deferred + wrappers. + + * Other + - Recommend Sub::Name 0.08, which fixes a memory leak. + - The values given to BUILD subs will be the original values passed to new, + rather than after coercions have been applied. This brings the behavior + in line with Moose. + +2.000002 - 2015-07-24 + - BUILDARGS will now always be called on object creation, even if no + attributes exist + - fix required attributes with spaces or other odd characters in init_arg + - fix (is => 'lazy', required => 1, init_arg => undef), which previously + didn't think it provided a builder + - under 'no Moo::sification', prevent automatic Moose metaclass inflation + from ->meta calls + - don't load Moo::Role for a ->does check if no roles could exist + - make global destruction test more robust from outside interference + - fix false default values satisfying required attributes + - Fix Moose attribute delegation to a Moo class via a wildcard + - work around case where Sub::Util is loadable but doesn't provide + Sub::Util::set_subname + - skip thread tests on perl 5.8.4 and below where threads are extremely + unreliable + - Allow stub methods (e.g. sub foo;) to be overwritten by accessors or other + generated methods. (RT#103804) + +2.000001 - 2015-03-16 + - Fix how we pick between Sub::Name and Sub::Util if they are both loaded. + This fixes how we interact with Moose in some cases. (RT#102729) (GH#15) + +2.000000 - 2015-03-02 + * Incompatible Changes + - Fatal warnings and the other additional checks from the strictures + module will no longer be applied to modules using Moo or Moo::Role. We + now only apply strict and (non-fatal) warnings, matching the behavior of + Moose. + - Classes without attributes used to store everything passed to ->new + in the object. This has been fixed to not store anything in the object, + making it consistent with classes that had attributes. + - Moo will now pass __no_BUILD__ to parent constructors when inheriting + from a Moose or Class::Tiny class, to prevent them from calling BUILD + functions. Moo calls the BUILD functions itself, which previously led + to them being called multiple times. + - Attempting to replace an existing constructor, or modify one that has + been used, will throw an error. This includes adding attributes. + Previously, this would result in some attributes being silently ignored + by the constructor. + - If a class's @ISA is modified without using 'extends' in a way that + affects object construction, Moo will detect this and throw an error. + This can happen in code that uses ->load_components from + Class::C3::Componentised, which is common in DBIx::Class modules. + + * Bug Fixes + - Fix calling class methods on Moo::HandleMoose::FakeMetaClass, such as + modules scanning all classes + + * Miscellaneous + - use Sub::Util instead of Sub::Name if available + +1.007000 - 2015-01-21 + - fix Moose metaclass inflation of Method::Generate::Constructor (RT#101111) + - clarify behavior of clearers for non-lazy attribute defaults + - add Sub::Defer::undefer_package to undefer all subs from a given package + - existing attributes will no longer be overwritten when composing roles. + Previously, the attribute configuration used by the constructor would be + overridden, but the attribute methods would not be. This caused a mismatch + in attribute behavior. + - link to Type::Tiny in docs rather than MooX::Types::MooseLike + - document exports of Sub::Defer + - fix capture_unroll usage in inlinify example + - fix needless re-assigning of variables in generated Sub::Quote subs + - fix global destruction test to work when perl path has spaces + +1.006001 - 2014-10-22 + - Name the ->DOES method installed by Role::Tiny + - don't apply threading workarounds on non-threaded perls, even if module for + it is loaded by something + - avoid loading base.pm and just set @ISA manually + - fix some Pod links to Class::Method::Modifiers + - fix applying roles with multiple attributes with defaults to objects + (RT#99217) + - fix Moose inheriting from a Moo class that inherits from a non-M* class + when the Moose class is not made immutable + - fix ->does method on Moose child classes of Moo classes + +1.006000 - 2014-08-16 + - support coerce => 1 in attributes, taking the coercion from the isa option + if it is an object that supports the coerce or coercion method. + - add attribute information to type check errors by trapping with an eval + rather than overriding the global __DIE__ handler + - bump Module::Runtime prerequisite to fix error messages when there is a + missing module used by a role loaded using 'with' or similar (rt#97669) + +1.005000 - 2014-06-10 + - add qsub to Sub::Quote as a prototyped alternative to quote_sub, accepting + only the sub body + - avoid testing UTF-8 on perl 5.6 + +1.004006 - 2014-05-27 + - fix quotify for characters in the \x80-\xFF range when used under the utf8 + pragma. Also fixes some cases of constructor generation with the pragma. + +1.004005 - 2014-05-23 + - releasing 1.004_004 as stable + +1.004_004 - 2014-05-12 + - stop internally depending on Moo::Object::new including all inputs in + constructed object + - be more careful when munging code for inlining + - fix maintaining source of quoted sub for lifetime of sub + - redo foreign C3 compatibility, fixing constructors without changing behavior + for Moo constructors + - don't build Moose metaclass when checking Moo classes with ->is_role + - include Sub::Name in recommendations metadata + +1.004_003 - 2014-04-13 + - always maintain source of quoted subs for the lifetime of the sub + - fix Sub::Quote and Sub::Defer leaking memory + - Class::XSAccessor is now listed as a recommended prerequisite + - fix generating a subclass with roles when using a non-standard accessor + - use alternate quoting routine, which is faster and saves memory by not + loading B.pm + - fix default of undef + - fix inheriting from a class with a prototype on new + - use ->is_role internally to check if a package is a role + - minimise Role::Tiny coupling outside Moo::Role + - fix calling parent constructor when C3 multiple inheritance is in use + (such as when combining with DBIx::Class) + - return true from Moo::Role->is_role for all loaded Moose roles + - improved test coverage + - fix strictures author test when PERL_STRICTURES_EXTRA is set + - remove Dist::CheckConflicts prerequisite and replace with a test to report + known broken downstream modules + - fix x_breaks metadata + +1.004002 - 2013-12-31 + - fix type inflation in threads when types are inserted by manually + stringifying the type first (like Type::Tiny) + - add undefer_all to Sub::Defer + +1.004001 - 2013-12-27 + - fix repository links in pod + - add missing changelog entry regarding strictures to 1.004000 release + +1.004000 - 2013-12-26 + - strictures will now be applied to modules using Moo just as if they + included "use strictures" directly. This means that strictures extra + checks will now apply to code in checkouts. + - fix handling of type inflation when used with threads + - don't include meta method when consuming Mouse roles + - inhale Moose roles for has attr => ( handles => "RoleName" ) + - provide useful error if attribute defined as required but with + init_arg => undef + - document that BUILDARGS isn't called when there are no attributes + - omit sub imported before use Moo from Moose method inflation + - check for FOREIGNBUILDARGS only once per class instead of on each + instantiation + - take advantage of XS predicates from newer versions of Class::XSAccessor + - always try to load superclasses and roles, and only fall back on the + heuristic of checking for subs if the file doesn't exist + - fix handling of attributes with names that aren't valid identifiers + - Quoted subs now preserve the package and pragmas from their calling code + - the official Moo git repository has moved to the Moose organization on + GitHub: https://github.com/moose/Moo + +1.003001 - 2013-09-10 + - abbreviate class names from created by create_class_with_roles if they are + too long for perl to handle (RT#83248) + - prevent destructors from failing in global destruction for certain + combinations of Moo and Moose classes subclassing each other (RT#87810) + - clarify in docs that Sub::Quote's captured variables are copies, not aliases + - fix infinite recursion if an isa check fails due to another isa check + (RT#87575) + - fix Sub::Quote and Sub::Defer under threads (RT#87043) + - better diagnostics when bad parameters given to has + +1.003000 - 2013-07-15 + - fix composing roles that require methods provided by the other (RT#82711) + - document optional use of Class::XSAccessor with caveats + - fix constructor generated when creating a class with + create_class_with_roles when the superclass constructor hasn't been + generated yet + - fix extending the constructor generator using Moo classes/roles + - non-lazy attribute defaults are used when applying a role to an object + - updated META files to list prerequisites in proper phases + - $Method::Generate::Accessor::CurrentAttribute hashref contains + information about attribute currently being processed (available + to exception objects thrown by "isa" and "coerce") + - properly die when composing a module that isn't a Role + - fix passing attribute parameters for traits when inflating to Moose + - fix inflating method modifiers applied to multiple methods + - fix documentation for Sub::Quote::capture_unroll + - add documentation noting Sub::Quote's use of strictures + - fix FOREIGNBUILDARGS not being called if no attributes created + +1.002000 - 2013-05-04 + - add 'moosify' attribute key to provide code for inflating to Moose + - fix warnings about unknown attribute parameters on metaclass inflation + - don't pass 'handles' down when doing 'has +' to avoid unDWIMmy explosions + - throw a useful exception when typemap doesn't return a value + - avoid localising @_ when not required for Sub::Quote + - successfully inflate a metaclass for attributeless classes (RT#86415) + - fix false default values used with non-lazy accessors + - stop built values that fail isa checks still getting stored in the object + - stop lazy+weak_ref accessors re-building their value on every call + - make lazy+weak_ref accessors return undef if built value isn't already + stored elsewhere (Moose compatibility) + - stop isa checks being called on every access for lazy attributes + - bump Devel::GlobalDestruction dependency to fix warning on cleanup + when run under -c (RT#78617) + - document Moose type constraint creation for roles and classes + (actually fixed in 1.001000) + +1.001000 - 2013-03-16 + - add support for FOREIGNBUILDARGS when inheriting from non-Moo classes + - non-ref default values are allowed without using a sub + - has will refuse to overwrite locally defined subs with generated + accessors. + - added more meta resources and added more support relevant links into + the POD documentation + - clarify in docs that default and built values won't call triggers + (RT#82310) + - expand is => 'lazy' doc to make it clear that you can make rw lazy + attributes if you really want to + - handles => "RoleName" tries to load the module + - fix delegation to false/undef attributes (RT#83361) + +1.000008 - 2013-02-06 + - Re-export on 'use Moo' after 'no Moo' + - Export meta() into roles (but mark as non-method to avoid composing it) + - Don't generate an accessor for rw attributes if reader+writer both set + - Support builder => sub {} ala MooseX::AttributeShortcuts + - Fix 'no Moo;' to preserve non-sub package variables + - Switch to testing for Mouse::Util->can('find_meta') to avoid + exploding on ancient Mouse installs + - Fix loading order bug that results in _install_coderef being treated + as indirect object notation + +1.000007 - 2012-12-15 + - Correctly handle methods dragged along by role composition + - Die if Moo and Moo::Role are imported into the same package + +1.000006 - 2012-11-16 + - Don't use $_ as loop variable when calling arbitrary code (RT#81072) + - Bump Role::Tiny prereq to fix method modifier breakage on 5.10.0 + +1.000005 - 2012-10-23 + - fix POD typo (RT#80060) + - include init_arg name in constructor errors (RT#79596) + - bump Class::Method::Modifiers dependency to avoid warnings on 5.8 + +1.000004 - 2012-10-03 + - allow 'has \@attributes' like Moose does + +1.000003 - 2012-08-09 + - make setter for weak_ref attributes return the value + +1.000002 - 2012-08-04 + - remove Devel::GlobalDestruction fallback inlining because we can now + depend on 0.08 which uses Sub::Exporter::Progressive + - honour BUILDARGS when calling $meta->new_object on behalf of Moose + - throw an error on invalid builder (RT#78479) + - fix stupid typo in new Sub::Quote section + +1.000001 - 2012-07-21 + - documentation tweaks and cleanup + - ignore required when default or builder is present + - document Moo versus Any::Moose in brief with article link + - remove quote_sub from SYNOPSIS and has docs, expand Sub::Quote section + - localize @_ when inlining quote_sub'ed isa checks (fixes lazy+isa+default) + - ensure constructor gets regenerated if forced early by metaclass inflation + +1.000000 - 2012-07-18 + - clean up doc language and expand on Moo and Moose + - error prefixes for isa and coerce exceptions + - unmark Moo and Moose as experimental since it's relatively solid now + - convert isa and coerce info from external role attributes + - clear method cache after metaclass generation to fix autoclean bug + +0.091014 - 2012-07-16 + - load overload.pm explicitly for overload::StrVal + +0.091013 - 2012-07-15 + - useful and detailed errors for coerce in attrib generation + +0.091012 - 2012-07-15 + - useful and detailed errors for default checker in attrib generation + - throw an error when trying to extend a role + +0.091011 - 2012-06-27 + - re-add #web-simple as development IRC + - don't assume Scalar::Util is imported into the current package + +0.091010 - 2012-06-26 + - isa checks on builders + - additional quote_sub docs + - remove multi-populate code to fix exists/defined new() bug + - document move to #moose and include repository metadata + - no Moo and no Moo::Role + - squelch used only once warnings for $Moo::HandleMoose::MOUSE + - MooClass->meta + - subconstructor handling for Moose classes + +0.091009 - 2012-06-20 + - squelch redefine warnings in the coderef installation code + +0.091008 - 2012-06-19 + - bump Role::Tiny dependency to get working modifiers under composition + - handle "has '+foo'" for attrs from superclass or consumed role + - document override -> around translation + - use D::GD if installed rather than re-adding it as a requirement + +0.091007 - 2012-05-17 + - remove stray reference to Devel::GlobalDestruction + +0.091006 - 2012-05-16 + - drop a couple of dependencies by minor releases we don't strictly need + +0.091005 - 2012-05-14 + - temporary switch to an inlined in_global_destruction to avoid needing + to fatpack Sub::Exporter for features we don't use + - re-order is documentation to give readonly styles more prominence + - a weakened value should still be returned on set (fixes lazy + weak_ref) + - add an explicit return to all exported subs so people don't accidentally + rely on the return value + +0.091004 - 2012-05-07 + - also inhale from Mouse + - clarify how isa and coerce interact + - support isa and coerce together for Moose + - guard _accessor_maker_for calls in Moo::Role in case Moo isn't loaded + - reset handlemoose state on mutation in case somebody reified the + metaclass too early + +0.091003 - 2012-05-06 + - improve attribute option documentation + - update the incompatibilities section since we're less incompatible now + - fix coderef naming to avoid confusing autoclean + +0.091002 - 2012-05-05 + - exclude union roles and same-role-as-self from metaclass inflation + - inhale Moose roles before checking for composition conflicts + - enable Moo::sification if only Moo::Role is loaded and not Moo + - preserve attribute ordering + - factor out accessor generation code a bit more to enable extension + +0.091001 - 2012-05-02 + - bump Role::Tiny dependency to require de-strictures-ed version + - fix test failure where Class::XSAccessor is not available + +0.091000 - 2012-04-27 + - document MX::AttributeShortcuts 009+ support + - documentation for the metaclass inflation code + - better error message for broken BUILDARGS + - provide 'no Moo::sification' to forcibly disable metaclass inflation + - switch to Devel::GlobalDestruction to correctly disarm the + Moo::sification trigger under threads + - make extends after has work + - name subs if Sub::Name is available for better stracktraces + - undefer all subs before creating a concrete Moose metaclass + - fix bug in _load_module where global vars could cause mis-detection + of the module already being loaded + +0.009_017 - 2012-04-16 + - mangle constructor meta-method on inflation so make_immutable works + - fix possible infinite loop caused by subconstructor code + +0.009_016 - 2012-04-12 + - don't accidentally load Moo::HandleMoose during global destruction + - better docs for trigger (and initializer's absence) + +0.009_015 - 2012-04-11 + - Complete support for MooseX::AttributeShortcuts 0.009 + - Allow Moo classes to compose Moose roles + - Introduce Moo::HandleMoose, which should allow Moo classes and roles + to be treated as Moose classes/roles. Supported so far: + - Some level of attributes and methods for both classes and roles + - Required methods in roles + - Method modifiers in roles (they're already applied in classes) + - Type constraints + +0.009014 - 2012-03-29 + - Split Role::Tiny out into its own dist + - Fix a bug where coercions weren't called on lazy default/builder returns + - Switch Moo::Utils to using Module::Runtime, and add the 5.8 %INC + leakage fix into Role::Tiny's _load_module to provide partial parity + - Update incompatibilities with Moose documentation + - Remove Sub::Quote's outstanding queue since it doesn't actually slow + things down to do it this way and makes debugging easier. + - Revert 'local $@' around require calls to avoid triggering Unknown Error + - Explicitly require Role::Tiny in Role::Tiny::With (RT#70446) + - Fix spurious 'once' warnings under perl -w + +0.009013 - 2011-12-23 + - fix up Class::XSAccessor version check to be more robust + - improved documentation + - fix failures on perls < 5.8.3 + - fix test failures on cygwin + +0.009012 - 2011-11-15 + - make Method::Generate::Constructor handle $obj->new + - fix bug where constants containing a reference weren't handled correctly + (ref(\[]) is 'REF' not 'SCALAR', ref(\v1) is 'VSTRING') + +0.009011 - 2011-10-03 + - add support for DEMOLISH + - add support for BUILDARGS + +0.009010 - 2011-07-20 + - missing new files for Role::Tiny::With + +0.009009 - 2011-07-20 + - remove the big scary warning because we seem to be mostly working now + - perl based getter dies if @_ > 1 (XSAccessor already did) + - add Role::Tiny::With for use in classes + - automatically generate constructors in subclasses when required so that + subclasses with a BUILD method but no attributes get it honoured + - add coerce handling + +0.009008 - 2011-06-03 + - transfer fix to _load_module to Role::Tiny and make a note it's an inline + - Bring back 5.8.1 compat + +0.009007 - 2011-02-25 + - I botched the copyright. re-disting. + +0.009006 - 2011-02-25 + - handle non-lazy default and builder when init_arg is undef + - add copyright and license info for downstream packagers + - weak ref checking for Sub::Quote to avoid bugs on refaddr reuse + - Switch composed role names to be a valid package name + +0.9.5 Tue Jan 11 2011 + - Fix clobberage of runtime-installed wrappers by Sub::Defer + - Fix nonMoo constructor firing through multiple layers of Moo + - Fix bug where nonMoo is mistakenly detected given a Moo superclass + with no attributes (and hence no own constructor) + +0.9.4 Mon Dec 13 2010 + - Automatic detection on non-Moo superclasses + +0.9.3 Sun Dec 5 2010 + - Fix _load_module to deal with pre-existing subpackages + +0.9.2 Wed Nov 17 2010 + - Add explanation of Moo's existence + - Change @ISA setting mechanism to deal with a big in 5.10.0's get_linear_isa + - Change 5.10 checks to >= to not try and load MRO::Compat on 5.10.0 + - Make 'perl -Moo' DTRT + +0.9.1 Tue Nov 16 2010 + - Initial release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3198d64 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,146 @@ +Changes +lib/Method/Generate/Accessor.pm +lib/Method/Generate/BuildAll.pm +lib/Method/Generate/Constructor.pm +lib/Method/Generate/DemolishAll.pm +lib/Moo.pm +lib/Moo/_mro.pm +lib/Moo/_strictures.pm +lib/Moo/_Utils.pm +lib/Moo/HandleMoose.pm +lib/Moo/HandleMoose/_TypeMap.pm +lib/Moo/HandleMoose/FakeMetaClass.pm +lib/Moo/Object.pm +lib/Moo/Role.pm +lib/Moo/sification.pm +lib/oo.pm +maint/Makefile.PL.include +Makefile.PL +MANIFEST This list of files +t/accessor-coerce.t +t/accessor-default.t +t/accessor-generator-extension.t +t/accessor-handles.t +t/accessor-isa.t +t/accessor-mixed.t +t/accessor-pred-clear.t +t/accessor-reader-writer.t +t/accessor-roles.t +t/accessor-shortcuts.t +t/accessor-trigger.t +t/accessor-weaken-pre-5_8_3.t +t/accessor-weaken.t +t/buildall-subconstructor.t +t/buildall.t +t/buildargs-error.t +t/buildargs.t +t/coerce-1.t +t/compose-conflicts.t +t/compose-non-role.t +t/compose-roles.t +t/constructor-modify.t +t/croak-locations.t +t/demolish-basics.t +t/demolish-bugs-eats_exceptions.t +t/demolish-bugs-eats_mini.t +t/demolish-global_destruction.t +t/demolish-throw.t +t/does.t +t/extend-constructor.t +t/extends-non-moo.t +t/extends-role.t +t/foreignbuildargs.t +t/global-destruction-helper.pl +t/global_underscore.t +t/has-array.t +t/has-before-extends.t +t/has-plus.t +t/init-arg.t +t/isa-interfere.t +t/lazy_isa.t +t/lib/ErrorLocation.pm +t/lib/InlineModule.pm +t/lib/TestEnv.pm +t/load_module.t +t/load_module_error.t +t/load_module_role_tiny.t +t/long-package-name.t +t/method-generate-accessor.t +t/method-generate-constructor.t +t/modify_lazy_handlers.t +t/moo-accessors.t +t/moo-c3.t +t/moo-object.t +t/moo-utils-_name_coderef.t +t/moo-utils-_subname.t +t/moo-utils.t +t/moo.t +t/mutual-requires.t +t/no-build.t +t/no-moo.t +t/non-moo-extends-c3.t +t/non-moo-extends.t +t/not-both.t +t/not-methods.t +t/overloaded-coderefs.t +t/overridden-core-funcs.t +t/perl-56-like.t +t/strictures.t +t/sub-and-handles.t +t/subconstructor.t +t/undef-bug.t +t/use-after-no.t +t/zzz-check-breaks.t +xt/bless-override.t +xt/class-tiny.t +xt/croak-locations.t +xt/fakemetaclass.t +xt/global-destruct-jenga-helper.pl +xt/global-destruct-jenga.t +xt/handle_moose.t +xt/has-after-meta.t +xt/implicit-moose-types.t +xt/inflate-our-classes.t +xt/inflate-undefer.t +xt/jenga.t +xt/moo-attr-handles-moose-role.t +xt/moo-consume-moose-role-coerce.t +xt/moo-consume-moose-role-multiple.t +xt/moo-consume-mouse-role-coerce.t +xt/moo-does-moose-role.t +xt/moo-does-mouse-role.t +xt/moo-extend-moose.t +xt/moo-inflate.t +xt/moo-object-meta-can.t +xt/moo-role-types.t +xt/moo-roles-into-moose-class-attr-override-with-autoclean.t +xt/moo-roles-into-moose-class.t +xt/moo-sification-handlemoose.t +xt/moo-sification-meta.t +xt/moo-sification.t +xt/moose-accessor-isa.t +xt/moose-autoclean-lazy-attr-builders.t +xt/moose-consume-moo-role-after-consumed-by-moo.t +xt/moose-consume-moo-role-no-moo-loaded.t +xt/moose-does-moo-role.t +xt/moose-extend-moo.t +xt/moose-handles-moo-class.t +xt/moose-inflate-error-recurse.t +xt/moose-lazy.t +xt/moose-method-modifiers.t +xt/moose-override-attribute-from-moo-role.t +xt/moose-override-attribute-with-plus-syntax.t +xt/more-jenga.t +xt/release/kwalitee.t +xt/role-tiny-inflate.t +xt/super-jenga.t +xt/test-my-dependents.t +xt/type-inflate-coercion.t +xt/type-inflate-threads.t +xt/type-inflate-type-tiny.t +xt/type-inflate.t +xt/type-tiny-coerce.t +xt/withautoclean.t +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) +README README file (added by Distar) diff --git a/META.json b/META.json new file mode 100644 index 0000000..2c3cb0a --- /dev/null +++ b/META.json @@ -0,0 +1,108 @@ +{ + "abstract" : "Minimalist Object Orientation (with Moose compatibility)", + "author" : [ + "mst - Matt S. Trout (cpan:MSTROUT) " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Moo", + "no_index" : { + "directory" : [ + "t", + "xt" + ] + }, + "prereqs" : { + "build" : { + "requires" : {} + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "develop" : { + "requires" : { + "Class::Tiny" : "1.001", + "Moose" : "0", + "MooseX::Types::Common::Numeric" : "0", + "Mouse" : "0", + "Type::Tiny" : "0", + "bareword::filehandles" : "0", + "indirect" : "0", + "multidimensional" : "0", + "namespace::autoclean" : "0", + "namespace::clean" : "0", + "strictures" : "2" + } + }, + "runtime" : { + "recommends" : { + "Class::XSAccessor" : "1.18", + "Sub::Name" : "0.08", + "strictures" : "2" + }, + "requires" : { + "Class::Method::Modifiers" : "1.1", + "Devel::GlobalDestruction" : "0.11", + "Exporter" : "5.57", + "Module::Runtime" : "0.014", + "Role::Tiny" : "2.000004", + "Scalar::Util" : "0", + "Sub::Defer" : "2.003001", + "Sub::Quote" : "2.003001", + "perl" : "5.006" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "0", + "CPAN::Meta::Requirements" : "0" + }, + "requires" : { + "Test::Fatal" : "0.003", + "Test::More" : "0.94" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-Moo@rt.cpan.org", + "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Moo" + }, + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "type" : "git", + "url" : "https://github.com/moose/Moo.git", + "web" : "https://github.com/moose/Moo" + }, + "x_IRC" : "irc://irc.perl.org/#moose" + }, + "version" : "2.003004", + "x_authority" : "cpan:MSTROUT", + "x_breaks" : { + "App::Commando" : "<= 0.012", + "File::DataClass" : "<= 0.54.1", + "HTML::Restrict" : "== 2.1.5", + "MooX::Emulate::Class::Accessor::Fast" : "<= 0.02", + "MySQL::Workbench::Parser" : "<= 0.05", + "WebService::Shutterstock" : "<= 0.006" + }, + "x_cpants" : { + "ignore" : { + "use_strict" : "internal module used to apply strict", + "use_warnings" : "internal module used to apply warnings" + } + }, + "x_serialization_backend" : "JSON::PP version 2.94" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7e62342 --- /dev/null +++ b/META.yml @@ -0,0 +1,53 @@ +--- +abstract: 'Minimalist Object Orientation (with Moose compatibility)' +author: + - 'mst - Matt S. Trout (cpan:MSTROUT) ' +build_requires: + Test::Fatal: '0.003' + Test::More: '0.94' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Moo +no_index: + directory: + - t + - xt +recommends: + Class::XSAccessor: '1.18' + Sub::Name: '0.08' + strictures: '2' +requires: + Class::Method::Modifiers: '1.1' + Devel::GlobalDestruction: '0.11' + Exporter: '5.57' + Module::Runtime: '0.014' + Role::Tiny: '2.000004' + Scalar::Util: '0' + Sub::Defer: '2.003001' + Sub::Quote: '2.003001' + perl: '5.006' +resources: + IRC: irc://irc.perl.org/#moose + bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Moo + license: http://dev.perl.org/licenses/ + repository: https://github.com/moose/Moo.git +version: '2.003004' +x_authority: cpan:MSTROUT +x_breaks: + App::Commando: '<= 0.012' + File::DataClass: '<= 0.54.1' + HTML::Restrict: '== 2.1.5' + MooX::Emulate::Class::Accessor::Fast: '<= 0.02' + MySQL::Workbench::Parser: '<= 0.05' + WebService::Shutterstock: '<= 0.006' +x_cpants: + ignore: + use_strict: 'internal module used to apply strict' + use_warnings: 'internal module used to apply warnings' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..7dd485c --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,160 @@ +use strict; +use warnings FATAL => 'all'; +use 5.006; + +my %META = ( + name => 'Moo', + license => 'perl_5', + prereqs => { + configure => { requires => { + 'ExtUtils::MakeMaker' => 0, + } }, + build => { requires => { + } }, + test => { + requires => { + 'Test::More' => 0.94, + 'Test::Fatal' => 0.003, + }, + recommends => { + 'CPAN::Meta' => 0, + 'CPAN::Meta::Requirements' => 0, + }, + }, + runtime => { + requires => { + 'Class::Method::Modifiers' => 1.10, # for RT#80194 + 'Module::Runtime' => 0.014, # for RT#86394 + 'Role::Tiny' => 2.000004, + 'Devel::GlobalDestruction' => 0.11, # for RT#78617 + 'Scalar::Util' => 0, + 'perl' => 5.006, + 'Exporter' => 5.57, # Import 'import' + 'Sub::Quote' => 2.003001, + 'Sub::Defer' => 2.003001, + }, + recommends => { + 'Class::XSAccessor' => 1.18, + 'Sub::Name' => 0.08, + 'strictures' => 2, + }, + }, + develop => { + requires => { + 'strictures' => 2, + 'indirect' => 0, + 'multidimensional' => 0, + 'bareword::filehandles' => 0, + 'Moose' => 0, + 'Mouse' => 0, + 'namespace::clean' => 0, + 'namespace::autoclean' => 0, + 'MooseX::Types::Common::Numeric' => 0, + 'Type::Tiny' => 0, + 'Class::Tiny' => 1.001, + }, + }, + }, + resources => { + repository => { + url => 'https://github.com/moose/Moo.git', + web => 'https://github.com/moose/Moo', + type => 'git', + }, + x_IRC => 'irc://irc.perl.org/#moose', + bugtracker => { + web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Moo', + mailto => 'bug-Moo@rt.cpan.org', + }, + license => [ 'http://dev.perl.org/licenses/' ], + }, + no_index => { + directory => [ 't', 'xt' ] + }, + x_breaks => { + 'HTML::Restrict' => '== 2.1.5', + 'MySQL::Workbench::Parser' => '<= 0.05', + 'MooX::Emulate::Class::Accessor::Fast' => '<= 0.02', + 'WebService::Shutterstock' => '<= 0.006', + 'File::DataClass' => '<= 0.54.1', + 'App::Commando' => '<= 0.012', + }, + x_authority => 'cpan:MSTROUT', + x_cpants => { ignore => { + use_strict => 'internal module used to apply strict', + use_warnings => 'internal module used to apply warnings', + } }, +); + +my %MM_ARGS = ( + PREREQ_PM => { + ("$]" >= 5.008_000 ? () : ('Task::Weaken' => 0)), + ("$]" >= 5.010_000 ? () : ('MRO::Compat' => 0)), + }, +); + +{ + package MY; + + sub test_via_harness { + my($self, $perl, $tests) = @_; + $perl .= ' -I'.$self->catdir('t','lib').' "-MTestEnv=$(MOO_TEST_ENV)"'; + return $self->SUPER::test_via_harness($perl, $tests); + } + + sub postamble { + my $MOO_TEST_ENV = !-f 'META.yml' ? "MOO_FATAL_WARNINGS" : ''; + <<"POSTAMBLE"; +MOO_TEST_ENV=$MOO_TEST_ENV +fulltest: test test_no_xs +test_no_xs: pure_all +\t\$(NOECHO)\$(MAKE) test MOO_TEST_ENV="\$(MOO_TEST_ENV),MOO_XS_DISABLE" +POSTAMBLE + } +} + +## BOILERPLATE ############################################################### +require ExtUtils::MakeMaker; +(do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; + +# have to do this since old EUMM dev releases miss the eval $VERSION line +my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; +my $mymeta = $eumm_version >= 6.57_02; +my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; + +($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; +($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; +$META{license} = [ $META{license} ] + if $META{license} && !ref $META{license}; +$MM_ARGS{LICENSE} = $META{license}[0] + if $META{license} && $eumm_version >= 6.30; +$MM_ARGS{NO_MYMETA} = 1 + if $mymeta_broken; +$MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } + unless -f 'META.yml'; +$MM_ARGS{PL_FILES} ||= {}; +$MM_ARGS{NORECURS} = 1 + if not exists $MM_ARGS{NORECURS}; + +for (qw(configure build test runtime)) { + my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; + my $r = $MM_ARGS{$key} = { + %{$META{prereqs}{$_}{requires} || {}}, + %{delete $MM_ARGS{$key} || {}}, + }; + defined $r->{$_} or delete $r->{$_} for keys %$r; +} + +$MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; + +delete $MM_ARGS{MIN_PERL_VERSION} + if $eumm_version < 6.47_01; +$MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} + if $eumm_version < 6.63_03; +$MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} + if $eumm_version < 6.55_01; +delete $MM_ARGS{CONFIGURE_REQUIRES} + if $eumm_version < 6.51_03; + +ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); +## END BOILERPLATE ########################################################### diff --git a/README b/README new file mode 100644 index 0000000..0a78776 --- /dev/null +++ b/README @@ -0,0 +1,777 @@ +NAME + Moo - Minimalist Object Orientation (with Moose compatibility) + +SYNOPSIS + package Cat::Food; + + use Moo; + use strictures 2; + use namespace::clean; + + sub feed_lion { + my $self = shift; + my $amount = shift || 1; + + $self->pounds( $self->pounds - $amount ); + } + + has taste => ( + is => 'ro', + ); + + has brand => ( + is => 'ro', + isa => sub { + die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ' + }, + ); + + has pounds => ( + is => 'rw', + isa => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 }, + ); + + 1; + + And elsewhere: + + my $full = Cat::Food->new( + taste => 'DELICIOUS.', + brand => 'SWEET-TREATZ', + pounds => 10, + ); + + $full->feed_lion; + + say $full->pounds; + +DESCRIPTION + "Moo" is an extremely light-weight Object Orientation system. It allows + one to concisely define objects and roles with a convenient syntax that + avoids the details of Perl's object system. "Moo" contains a subset of + Moose and is optimised for rapid startup. + + "Moo" avoids depending on any XS modules to allow for simple + deployments. The name "Moo" is based on the idea that it provides almost + -- but not quite -- two thirds of Moose. + + Unlike Mouse this module does not aim at full compatibility with Moose's + surface syntax, preferring instead to provide full interoperability via + the metaclass inflation capabilities described in "MOO AND MOOSE". + + For a full list of the minor differences between Moose and Moo's surface + syntax, see "INCOMPATIBILITIES WITH MOOSE". + +WHY MOO EXISTS + If you want a full object system with a rich Metaprotocol, Moose is + already wonderful. + + But if you don't want to use Moose, you may not want "less metaprotocol" + like Mouse offers, but you probably want "no metaprotocol", which is + what Moo provides. "Moo" is ideal for some situations where deployment + or startup time precludes using Moose and Mouse: + + a command line or CGI script where fast startup is essential + code designed to be deployed as a single file via App::FatPacker + a CPAN module that may be used by others in the above situations + + "Moo" maintains transparent compatibility with Moose so if you install + and load Moose you can use Moo classes and roles in Moose code without + modification. + + Moo -- Minimal Object Orientation -- aims to make it smooth to upgrade + to Moose when you need more than the minimal features offered by Moo. + +MOO AND MOOSE + If Moo detects Moose being loaded, it will automatically register + metaclasses for your Moo and Moo::Role packages, so you should be able + to use them in Moose code without modification. + + Moo will also create Moose type constraints for Moo classes and roles, + so that in Moose classes "isa => 'MyMooClass'" and "isa => 'MyMooRole'" + work the same as for Moose classes and roles. + + Extending a Moose class or consuming a Moose::Role will also work. + + Extending a Mouse class or consuming a Mouse::Role will also work. But + note that we don't provide Mouse metaclasses or metaroles so the other + way around doesn't work. This feature exists for Any::Moose users + porting to Moo; enabling Mouse users to use Moo classes is not a + priority for us. + + This means that there is no need for anything like Any::Moose for Moo + code - Moo and Moose code should simply interoperate without problem. To + handle Mouse code, you'll likely need an empty Moo role or class + consuming or extending the Mouse stuff since it doesn't register true + Moose metaclasses like Moo does. + + If you need to disable the metaclass creation, add: + + no Moo::sification; + + to your code before Moose is loaded, but bear in mind that this switch + is global and turns the mechanism off entirely so don't put this in + library code. + +MOO AND CLASS::XSACCESSOR + If a new enough version of Class::XSAccessor is available, it will be + used to generate simple accessors, readers, and writers for better + performance. Simple accessors are those without lazy defaults, type + checks/coercions, or triggers. Simple readers are those without lazy + defaults. Readers and writers generated by Class::XSAccessor will behave + slightly differently: they will reject attempts to call them with the + incorrect number of parameters. + +MOO VERSUS ANY::MOOSE + Any::Moose will load Mouse normally, and Moose in a program using Moose + - which theoretically allows you to get the startup time of Mouse + without disadvantaging Moose users. + + Sadly, this doesn't entirely work, since the selection is load order + dependent - Moo's metaclass inflation system explained above in "MOO AND + MOOSE" is significantly more reliable. + + So if you want to write a CPAN module that loads fast or has only pure + perl dependencies but is also fully usable by Moose users, you should be + using Moo. + + For a full explanation, see the article + which + explains the differing strategies in more detail and provides a direct + example of where Moo succeeds and Any::Moose fails. + +PUBLIC METHODS + Moo provides several methods to any class using it. + + new + Foo::Bar->new( attr1 => 3 ); + + or + + Foo::Bar->new({ attr1 => 3 }); + + The constructor for the class. By default it will accept attributes + either as a hashref, or a list of key value pairs. This can be + customized with the "BUILDARGS" method. + + does + if ($foo->does('Some::Role1')) { + ... + } + + Returns true if the object composes in the passed role. + + DOES + if ($foo->DOES('Some::Role1') || $foo->DOES('Some::Class1')) { + ... + } + + Similar to "does", but will also return true for both composed roles and + superclasses. + + meta + my $meta = Foo::Bar->meta; + my @methods = $meta->get_method_list; + + Returns an object that will behave as if it is a Moose metaclass object + for the class. If you call anything other than "make_immutable" on it, + the object will be transparently upgraded to a genuine + Moose::Meta::Class instance, loading Moose in the process if required. + "make_immutable" itself is a no-op, since we generate metaclasses that + are already immutable, and users converting from Moose had an + unfortunate tendency to accidentally load Moose by calling it. + +LIFECYCLE METHODS + There are several methods that you can define in your class to control + construction and destruction of objects. They should be used rather than + trying to modify "new" or "DESTROY" yourself. + + BUILDARGS + around BUILDARGS => sub { + my ( $orig, $class, @args ) = @_; + + return { attr1 => $args[0] } + if @args == 1 && !ref $args[0]; + + return $class->$orig(@args); + }; + + Foo::Bar->new( 3 ); + + This class method is used to transform the arguments to "new" into a + hash reference of attribute values. + + The default implementation accepts a hash or hash reference of named + parameters. If it receives a single argument that isn't a hash reference + it will throw 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. + + FOREIGNBUILDARGS + sub FOREIGNBUILDARGS { + my ( $class, $options ) = @_; + return $options->{foo}; + } + + If you are inheriting from a non-Moo class, the arguments passed to the + parent class constructor can be manipulated by defining a + "FOREIGNBUILDARGS" method. It will receive the same arguments as + "BUILDARGS", and should return a list of arguments to pass to the parent + class constructor. + + BUILD + sub BUILD { + my ($self, $args) = @_; + die "foo and bar cannot be used at the same time" + if exists $args->{foo} && exists $args->{bar}; + } + + On object creation, any "BUILD" methods in the class's inheritance + hierarchy will be called on the object and given the results of + "BUILDARGS". They each will be called in order from the parent classes + down to the child, and thus should not themselves call the parent's + method. Typically this is used for object validation or possibly + logging. + + DEMOLISH + sub DEMOLISH { + my ($self, $in_global_destruction) = @_; + ... + } + + When an object is destroyed, any "DEMOLISH" methods in the inheritance + hierarchy will be called on the object. They are given boolean to inform + them if global destruction is in progress, and are called from the child + class upwards to the parent. This is similar to "BUILD" methods but in + the opposite order. + + Note that this is implemented by a "DESTROY" method, which is only + created on on the first construction of an object of your class. This + saves on overhead for classes that are never instantiated or those + without "DEMOLISH" methods. If you try to define your own "DESTROY", + this will cause undefined results. + +IMPORTED SUBROUTINES + extends + extends 'Parent::Class'; + + Declares a base class. Multiple superclasses can be passed for multiple + inheritance but please consider using roles instead. The class will be + loaded but no errors will be triggered if the class can't be found and + there are already subs in the class. + + Calling extends more than once will REPLACE your superclasses, not add + to them like 'use base' would. + + with + with 'Some::Role1'; + + or + + with 'Some::Role1', 'Some::Role2'; + + Composes one or more Moo::Role (or Role::Tiny) roles into the current + class. An error will be raised if these roles cannot be composed because + they have conflicting method definitions. The roles will be loaded using + the same mechanism as "extends" uses. + + has + has attr => ( + is => 'ro', + ); + + Declares an attribute for the class. + + package Foo; + use Moo; + has 'attr' => ( + is => 'ro' + ); + + package Bar; + use Moo; + extends 'Foo'; + has '+attr' => ( + default => sub { "blah" }, + ); + + Using the "+" notation, it's possible to override an attribute. + + has [qw(attr1 attr2 attr3)] => ( + is => 'ro', + ); + + Using an arrayref with multiple attribute names, it's possible to + declare multiple attributes with the same options. + + The options for "has" are as follows: + + "is" + required, may be "ro", "lazy", "rwp" or "rw". + + "ro" stands for "read-only" and generates an accessor that dies if you + attempt to write to it - i.e. a getter only - by defaulting "reader" + to the name of the attribute. + + "lazy" generates a reader like "ro", but also sets "lazy" to 1 and + "builder" to "_build_${attribute_name}" to allow on-demand generated + attributes. This feature was my attempt to fix my incompetence when + originally designing "lazy_build", and is also implemented by + MooseX::AttributeShortcuts. There is, however, nothing to stop you + using "lazy" and "builder" yourself with "rwp" or "rw" - it's just + that this isn't generally a good idea so we don't provide a shortcut + for it. + + "rwp" stands for "read-write protected" and generates a reader like + "ro", but also sets "writer" to "_set_${attribute_name}" for + attributes that are designed to be written from inside of the class, + but read-only from outside. This feature comes from + MooseX::AttributeShortcuts. + + "rw" stands for "read-write" and generates a normal getter/setter by + defaulting the "accessor" to the name of the attribute specified. + + "isa" + Takes a coderef which is used to validate the attribute. Unlike Moose, + Moo does not include a basic type system, so instead of doing "isa => + 'Num'", one should do + + use Scalar::Util qw(looks_like_number); + ... + isa => sub { + die "$_[0] is not a number!" unless looks_like_number $_[0] + }, + + Note that the return value for "isa" is discarded. Only if the sub + dies does type validation fail. + + Sub::Quote aware + + Since Moo does not run the "isa" check before "coerce" if a coercion + subroutine has been supplied, "isa" checks are not structural to your + code and can, if desired, be omitted on non-debug builds (although if + this results in an uncaught bug causing your program to break, the Moo + authors guarantee nothing except that you get to keep both halves). + + If you want Moose compatible or MooseX::Types style named types, look + at Type::Tiny. + + To cause your "isa" entries to be automatically mapped to named + Moose::Meta::TypeConstraint objects (rather than the default behaviour + of creating an anonymous type), set: + + $Moo::HandleMoose::TYPE_MAP{$isa_coderef} = sub { + require MooseX::Types::Something; + return MooseX::Types::Something::TypeName(); + }; + + Note that this example is purely illustrative; anything that returns a + Moose::Meta::TypeConstraint object or something similar enough to it + to make Moose happy is fine. + + "coerce" + Takes a coderef which is meant to coerce the attribute. The basic idea + is to do something like the following: + + coerce => sub { + $_[0] % 2 ? $_[0] : $_[0] + 1 + }, + + Note that Moo will always execute your coercion: this is to permit + "isa" entries to be used purely for bug trapping, whereas coercions + are always structural to your code. We do, however, apply any supplied + "isa" check after the coercion has run to ensure that it returned a + valid value. + + Sub::Quote aware + + If the "isa" option is a blessed object providing a "coerce" or + "coercion" method, then the "coerce" option may be set to just 1. + + "handles" + Takes a string + + handles => 'RobotRole' + + Where "RobotRole" is a role that defines an interface which becomes + the list of methods to handle. + + Takes a list of methods + + handles => [ qw( one two ) ] + + Takes a hashref + + handles => { + un => 'one', + } + + "trigger" + Takes a coderef which will get called any time the attribute is set. + This includes the constructor, but not default or built values. The + coderef will be invoked against the object with the new value as an + argument. + + If you set this to just 1, it generates a trigger which calls the + "_trigger_${attr_name}" method on $self. This feature comes from + MooseX::AttributeShortcuts. + + Note that Moose also passes the old value, if any; this feature is not + yet supported. + + Sub::Quote aware + + "default" + Takes a coderef which will get called with $self as its only argument + to populate an attribute if no value for that attribute was supplied + to the constructor. Alternatively, if the attribute is lazy, "default" + executes when the attribute is first retrieved if no value has yet + been provided. + + If a simple scalar is provided, it will be inlined as a string. Any + non-code reference (hash, array) will result in an error - for that + case instead use a code reference that returns the desired value. + + Note that if your default is fired during new() there is no guarantee + that other attributes have been populated yet so you should not rely + on their existence. + + Sub::Quote aware + + "predicate" + Takes a method name which will return true if an attribute has a + value. + + If you set this to just 1, the predicate is automatically named + "has_${attr_name}" if your attribute's name does not start with an + underscore, or "_has_${attr_name_without_the_underscore}" if it does. + This feature comes from MooseX::AttributeShortcuts. + + "builder" + Takes a method name which will be called to create the attribute - + functions exactly like default except that instead of calling + + $default->($self); + + Moo will call + + $self->$builder; + + The following features come from MooseX::AttributeShortcuts: + + If you set this to just 1, the builder is automatically named + "_build_${attr_name}". + + If you set this to a coderef or code-convertible object, that variable + will be installed under "$class::_build_${attr_name}" and the builder + set to the same name. + + "clearer" + Takes a method name which will clear the attribute. + + If you set this to just 1, the clearer is automatically named + "clear_${attr_name}" if your attribute's name does not start with an + underscore, or "_clear_${attr_name_without_the_underscore}" if it + does. This feature comes from MooseX::AttributeShortcuts. + + NOTE: If the attribute is "lazy", it will be regenerated from + "default" or "builder" the next time it is accessed. If it is not + lazy, it will be "undef". + + "lazy" + Boolean. Set this if you want values for the attribute to be grabbed + lazily. This is usually a good idea if you have a "builder" which + requires another attribute to be set. + + "required" + Boolean. Set this if the attribute must be passed on object + instantiation. + + "reader" + The name of the method that returns the value of the attribute. If you + like Java style methods, you might set this to "get_foo" + + "writer" + The value of this attribute will be the name of the method to set the + value of the attribute. If you like Java style methods, you might set + this to "set_foo". + + "weak_ref" + Boolean. Set this if you want the reference that the attribute + contains to be weakened. Use this when circular references, which + cause memory leaks, are possible. + + "init_arg" + Takes the name of the key to look for at instantiation time of the + object. A common use of this is to make an underscored attribute have + a non-underscored initialization name. "undef" means that passing the + value in on instantiation is ignored. + + "moosify" + Takes either a coderef or array of coderefs which is meant to + transform the given attributes specifications if necessary when + upgrading to a Moose role or class. You shouldn't need this by + default, but is provided as a means of possible extensibility. + + before + before foo => sub { ... }; + + See "before method(s) => sub { ... };" in Class::Method::Modifiers for + full documentation. + + around + around foo => sub { ... }; + + See "around method(s) => sub { ... };" in Class::Method::Modifiers for + full documentation. + + after + after foo => sub { ... }; + + See "after method(s) => sub { ... };" in Class::Method::Modifiers for + full documentation. + +SUB QUOTE AWARE + "quote_sub" in Sub::Quote allows us to create coderefs that are + "inlineable," giving us a handy, XS-free speed boost. Any option that is + Sub::Quote aware can take advantage of this. + + To do this, you can write + + use Sub::Quote; + + use Moo; + use namespace::clean; + + has foo => ( + is => 'ro', + isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 }) + ); + + which will be inlined as + + do { + local @_ = ($_[0]->{foo}); + die "Not <3" unless $_[0] < 3; + } + + or to avoid localizing @_, + + has foo => ( + is => 'ro', + isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 }) + ); + + which will be inlined as + + do { + my ($val) = ($_[0]->{foo}); + die "Not <3" unless $val < 3; + } + + See Sub::Quote for more information, including how to pass lexical + captures that will also be compiled into the subroutine. + +CLEANING UP IMPORTS + Moo will not clean up imported subroutines for you; you will have to do + that manually. The recommended way to do this is to declare your imports + first, then "use Moo", then "use namespace::clean". Anything imported + before namespace::clean will be scrubbed. Anything imported or declared + after will be still be available. + + package Record; + + use Digest::MD5 qw(md5_hex); + + use Moo; + use namespace::clean; + + has name => (is => 'ro', required => 1); + has id => (is => 'lazy'); + sub _build_id { + my ($self) = @_; + return md5_hex($self->name); + } + + 1; + + If you were to import "md5_hex" after namespace::clean you would be able + to call "->md5_hex()" on your "Record" instances (and it probably + wouldn't do what you expect!). + + Moo::Roles behave slightly differently. Since their methods are composed + into the consuming class, they can do a little more for you + automatically. As long as you declare your imports before calling "use + Moo::Role", those imports and the ones Moo::Role itself provides will + not be composed into consuming classes so there's usually no need to use + namespace::clean. + + On namespace::autoclean: Older versions of namespace::autoclean would + inflate Moo classes to full Moose classes, losing the benefits of Moo. + If you want to use namespace::autoclean with a Moo class, make sure you + are using version 0.16 or newer. + +INCOMPATIBILITIES WITH MOOSE + There is no built-in type system. "isa" is verified with a coderef; if + you need complex types, Type::Tiny can provide types, type libraries, + and will work seamlessly with both Moo and Moose. Type::Tiny can be + considered the successor to MooseX::Types and provides a similar API, so + that you can write + + use Types::Standard qw(Int); + has days_to_live => (is => 'ro', isa => Int); + + "initializer" is not supported in core since the author considers it to + be a bad idea and Moose best practices recommend avoiding it. Meanwhile + "trigger" or "coerce" are more likely to be able to fulfill your needs. + + There is no meta object. If you need this level of complexity you need + Moose - Moo is small because it explicitly does not provide a + metaprotocol. However, if you load Moose, then + + Class::MOP::class_of($moo_class_or_role) + + will return an appropriate metaclass pre-populated by Moo. + + No support for "super", "override", "inner", or "augment" - the author + considers augment to be a bad idea, and override can be translated: + + override foo => sub { + ... + super(); + ... + }; + + around foo => sub { + my ($orig, $self) = (shift, shift); + ... + $self->$orig(@_); + ... + }; + + The "dump" method is not provided by default. The author suggests + loading Devel::Dwarn into "main::" (via "perl -MDevel::Dwarn ..." for + example) and using "$obj->$::Dwarn()" instead. + + "default" only supports coderefs and plain scalars, because passing a + hash or array reference as a default is almost always incorrect since + the value is then shared between all objects using that default. + + "lazy_build" is not supported; you are instead encouraged to use the "is + => 'lazy'" option supported by Moo and MooseX::AttributeShortcuts. + + "auto_deref" is not supported since the author considers it a bad idea + and it has been considered best practice to avoid it for some time. + + "documentation" will show up in a Moose metaclass created from your + class but is otherwise ignored. Then again, Moose ignores it as well, so + this is arguably not an incompatibility. + + Since "coerce" does not require "isa" to be defined but Moose does + require it, the metaclass inflation for coerce alone is a trifle insane + and if you attempt to subtype the result will almost certainly break. + + Handling of warnings: when you "use Moo" we enable strict and warnings, + in a similar way to Moose. The authors recommend the use of + "strictures", which enables FATAL warnings, and several extra pragmas + when used in development: indirect, multidimensional, and + bareword::filehandles. + + Additionally, Moo supports a set of attribute option shortcuts intended + to reduce common boilerplate. The set of shortcuts is the same as in the + Moose module MooseX::AttributeShortcuts as of its version 0.009+. So if + you: + + package MyClass; + use Moo; + use strictures 2; + + The nearest Moose invocation would be: + + package MyClass; + + use Moose; + use warnings FATAL => "all"; + use MooseX::AttributeShortcuts; + + or, if you're inheriting from a non-Moose class, + + package MyClass; + + use Moose; + use MooseX::NonMoose; + use warnings FATAL => "all"; + use MooseX::AttributeShortcuts; + + Finally, Moose requires you to call + + __PACKAGE__->meta->make_immutable; + + at the end of your class to get an inlined (i.e. not horribly slow) + constructor. Moo does it automatically the first time ->new is called on + your class. ("make_immutable" is a no-op in Moo to ease migration.) + + An extension MooX::late exists to ease translating Moose packages to Moo + by providing a more Moose-like interface. + +SUPPORT + Users' IRC: #moose on irc.perl.org + + Development and contribution IRC: #web-simple on irc.perl.org + + Bugtracker: + + Git repository: + + Git browser: + +AUTHOR + mst - Matt S. Trout (cpan:MSTROUT) + +CONTRIBUTORS + dg - David Leadbeater (cpan:DGL) + + frew - Arthur Axel "fREW" Schmidt (cpan:FREW) + + hobbs - Andrew Rodland (cpan:ARODLAND) + + jnap - John Napiorkowski (cpan:JJNAPIORK) + + ribasushi - Peter Rabbitson (cpan:RIBASUSHI) + + chip - Chip Salzenberg (cpan:CHIPS) + + ajgb - Alex J. G. Burzyński (cpan:AJGB) + + doy - Jesse Luehrs (cpan:DOY) + + perigrin - Chris Prather (cpan:PERIGRIN) + + Mithaldu - Christian Walde (cpan:MITHALDU) + + + ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) + + tobyink - Toby Inkster (cpan:TOBYINK) + + haarg - Graham Knop (cpan:HAARG) + + mattp - Matt Phillips (cpan:MATTP) + + bluefeet - Aran Deltac (cpan:BLUEFEET) + + bubaflub - Bob Kuo (cpan:BUBAFLUB) + + ether = Karen Etheridge (cpan:ETHER) + +COPYRIGHT + Copyright (c) 2010-2015 the Moo "AUTHOR" and "CONTRIBUTORS" as listed + above. + +LICENSE + This library is free software and may be distributed under the same + terms as perl itself. See . + diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm new file mode 100644 index 0000000..4235fc2 --- /dev/null +++ b/lib/Method/Generate/Accessor.pm @@ -0,0 +1,696 @@ +package Method::Generate::Accessor; + +use Moo::_strictures; +use Moo::_Utils qw(_load_module _maybe_load_module _install_coderef); +use Moo::Object (); +BEGIN { our @ISA = qw(Moo::Object) } +use Sub::Quote qw(quote_sub quoted_from_sub quotify sanitize_identifier); +use Scalar::Util 'blessed'; +use Carp qw(croak); +BEGIN { our @CARP_NOT = qw(Moo::_Utils) } +BEGIN { + *_CAN_WEAKEN_READONLY = ( + "$]" < 5.008_003 or $ENV{MOO_TEST_PRE_583} + ) ? sub(){0} : sub(){1}; + our $CAN_HAZ_XS = + !$ENV{MOO_XS_DISABLE} + && + _maybe_load_module('Class::XSAccessor') + && + (eval { Class::XSAccessor->VERSION('1.07') }) + ; + our $CAN_HAZ_XS_PRED = + $CAN_HAZ_XS && + (eval { Class::XSAccessor->VERSION('1.17') }) + ; +} +BEGIN { + package + Method::Generate::Accessor::_Generated; + $Carp::Internal{+__PACKAGE__} = 1; +} + +my $module_name_only = qr/\A$Module::Runtime::module_name_rx\z/; + +sub _die_overwrite +{ + my ($pkg, $method, $type) = @_; + croak "You cannot overwrite a locally defined method ($method) with " + . ( $type || 'an accessor' ); +} + +sub generate_method { + my ($self, $into, $name, $spec, $quote_opts) = @_; + $quote_opts = { + no_defer => 1, + package => 'Method::Generate::Accessor::_Generated', + %{ $quote_opts||{} }, + }; + $spec->{allow_overwrite}++ if $name =~ s/^\+//; + croak "Must have an is" unless my $is = $spec->{is}; + if ($is eq 'ro') { + $spec->{reader} = $name unless exists $spec->{reader}; + } elsif ($is eq 'rw') { + $spec->{accessor} = $name unless exists $spec->{accessor} + or ( $spec->{reader} and $spec->{writer} ); + } elsif ($is eq 'lazy') { + $spec->{reader} = $name unless exists $spec->{reader}; + $spec->{lazy} = 1; + $spec->{builder} ||= '_build_'.$name unless exists $spec->{default}; + } elsif ($is eq 'rwp') { + $spec->{reader} = $name unless exists $spec->{reader}; + $spec->{writer} = "_set_${name}" unless exists $spec->{writer}; + } elsif ($is ne 'bare') { + croak "Unknown is ${is}"; + } + if (exists $spec->{builder}) { + if(ref $spec->{builder}) { + $self->_validate_codulatable('builder', $spec->{builder}, + "$into->$name", 'or a method name'); + $spec->{builder_sub} = $spec->{builder}; + $spec->{builder} = 1; + } + $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1; + croak "Invalid builder for $into->$name - not a valid method name" + if $spec->{builder} !~ $module_name_only; + } + if (($spec->{predicate}||0) eq 1) { + $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}"; + } + if (($spec->{clearer}||0) eq 1) { + $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}"; + } + if (($spec->{trigger}||0) eq 1) { + $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)'); + } + if (($spec->{coerce}||0) eq 1) { + my $isa = $spec->{isa}; + if (blessed $isa and $isa->can('coercion')) { + $spec->{coerce} = $isa->coercion; + } elsif (blessed $isa and $isa->can('coerce')) { + $spec->{coerce} = sub { $isa->coerce(@_) }; + } else { + croak "Invalid coercion for $into->$name - no appropriate type constraint"; + } + } + + foreach my $setting (qw( isa coerce )) { + next if !exists $spec->{$setting}; + $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name"); + } + + if (exists $spec->{default}) { + if (ref $spec->{default}) { + $self->_validate_codulatable('default', $spec->{default}, "$into->$name", + 'or a non-ref'); + } + } + + if (exists $spec->{moosify}) { + if (ref $spec->{moosify} ne 'ARRAY') { + $spec->{moosify} = [$spec->{moosify}]; + } + + foreach my $spec (@{$spec->{moosify}}) { + $self->_validate_codulatable('moosify', $spec, "$into->$name"); + } + } + + my %methods; + if (my $reader = $spec->{reader}) { + _die_overwrite($into, $reader, 'a reader') + if !$spec->{allow_overwrite} && defined &{"${into}::${reader}"}; + if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) { + $methods{$reader} = $self->_generate_xs( + getters => $into, $reader, $name, $spec + ); + } else { + $self->{captures} = {}; + $methods{$reader} = + quote_sub "${into}::${reader}" + => ' Carp::croak("'.$reader.' is a read-only accessor") if @_ > 1;'."\n" + .$self->_generate_get($name, $spec) + => delete $self->{captures} + => $quote_opts + ; + } + } + if (my $accessor = $spec->{accessor}) { + _die_overwrite($into, $accessor, 'an accessor') + if !$spec->{allow_overwrite} && defined &{"${into}::${accessor}"}; + if ( + our $CAN_HAZ_XS + && $self->is_simple_get($name, $spec) + && $self->is_simple_set($name, $spec) + ) { + $methods{$accessor} = $self->_generate_xs( + accessors => $into, $accessor, $name, $spec + ); + } else { + $self->{captures} = {}; + $methods{$accessor} = + quote_sub "${into}::${accessor}" + => $self->_generate_getset($name, $spec) + => delete $self->{captures} + => $quote_opts + ; + } + } + if (my $writer = $spec->{writer}) { + _die_overwrite($into, $writer, 'a writer') + if !$spec->{allow_overwrite} && defined &{"${into}::${writer}"}; + if ( + our $CAN_HAZ_XS + && $self->is_simple_set($name, $spec) + ) { + $methods{$writer} = $self->_generate_xs( + setters => $into, $writer, $name, $spec + ); + } else { + $self->{captures} = {}; + $methods{$writer} = + quote_sub "${into}::${writer}" + => $self->_generate_set($name, $spec) + => delete $self->{captures} + => $quote_opts + ; + } + } + if (my $pred = $spec->{predicate}) { + _die_overwrite($into, $pred, 'a predicate') + if !$spec->{allow_overwrite} && defined &{"${into}::${pred}"}; + if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) { + $methods{$pred} = $self->_generate_xs( + exists_predicates => $into, $pred, $name, $spec + ); + } else { + $self->{captures} = {}; + $methods{$pred} = + quote_sub "${into}::${pred}" + => $self->_generate_simple_has('$_[0]', $name, $spec)."\n" + => delete $self->{captures} + => $quote_opts + ; + } + } + if (my $builder = delete $spec->{builder_sub}) { + _install_coderef( "${into}::$spec->{builder}" => $builder ); + } + if (my $cl = $spec->{clearer}) { + _die_overwrite($into, $cl, 'a clearer') + if !$spec->{allow_overwrite} && defined &{"${into}::${cl}"}; + $self->{captures} = {}; + $methods{$cl} = + quote_sub "${into}::${cl}" + => $self->_generate_simple_clear('$_[0]', $name, $spec)."\n" + => delete $self->{captures} + => $quote_opts + ; + } + if (my $hspec = $spec->{handles}) { + my $asserter = $spec->{asserter} ||= '_assert_'.$name; + my @specs = do { + if (ref($hspec) eq 'ARRAY') { + map [ $_ => $_ ], @$hspec; + } elsif (ref($hspec) eq 'HASH') { + map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ], + keys %$hspec; + } elsif (!ref($hspec)) { + require Moo::Role; + _load_module $hspec; + map [ $_ => $_ ], Moo::Role->methods_provided_by($hspec) + } else { + croak "You gave me a handles of ${hspec} and I have no idea why"; + } + }; + foreach my $delegation_spec (@specs) { + my ($proxy, $target, @args) = @$delegation_spec; + _die_overwrite($into, $proxy, 'a delegation') + if !$spec->{allow_overwrite} && defined &{"${into}::${proxy}"}; + $self->{captures} = {}; + $methods{$proxy} = + quote_sub "${into}::${proxy}" + => $self->_generate_delegation($asserter, $target, \@args) + => delete $self->{captures} + => $quote_opts + ; + } + } + if (my $asserter = $spec->{asserter}) { + _die_overwrite($into, $asserter, 'an asserter') + if !$spec->{allow_overwrite} && defined &{"${into}::${asserter}"}; + local $self->{captures} = {}; + $methods{$asserter} = + quote_sub "${into}::${asserter}" + => $self->_generate_asserter($name, $spec) + => delete $self->{captures} + => $quote_opts + ; + } + \%methods; +} + +sub merge_specs { + my ($self, @specs) = @_; + my $spec = shift @specs; + for my $old_spec (@specs) { + foreach my $key (keys %$old_spec) { + if ($key eq 'handles') { + } + elsif ($key eq 'moosify') { + $spec->{$key} = [ + map { ref $_ eq 'ARRAY' ? @$_ : $_ } + grep defined, + ($old_spec->{$key}, $spec->{$key}) + ]; + } + elsif (!exists $spec->{$key}) { + $spec->{$key} = $old_spec->{$key}; + } + } + } + $spec; +} + +sub is_simple_attribute { + my ($self, $name, $spec) = @_; + # clearer doesn't have to be listed because it doesn't + # affect whether defined/exists makes a difference + !grep $spec->{$_}, + qw(lazy default builder coerce isa trigger predicate weak_ref); +} + +sub is_simple_get { + my ($self, $name, $spec) = @_; + !($spec->{lazy} and (exists $spec->{default} or $spec->{builder})); +} + +sub is_simple_set { + my ($self, $name, $spec) = @_; + !grep $spec->{$_}, qw(coerce isa trigger weak_ref); +} + +sub has_default { + my ($self, $name, $spec) = @_; + $spec->{builder} or exists $spec->{default} or (($spec->{is}||'') eq 'lazy'); +} + +sub has_eager_default { + my ($self, $name, $spec) = @_; + (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder})); +} + +sub _generate_get { + my ($self, $name, $spec) = @_; + my $simple = $self->_generate_simple_get('$_[0]', $name, $spec); + if ($self->is_simple_get($name, $spec)) { + $simple; + } else { + $self->_generate_use_default( + '$_[0]', $name, $spec, + $self->_generate_simple_has('$_[0]', $name, $spec), + ); + } +} + +sub generate_simple_has { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_simple_has(@_); + ($code, delete $self->{captures}); +} + +sub _generate_simple_has { + my ($self, $me, $name) = @_; + "exists ${me}->{${\quotify $name}}"; +} + +sub _generate_simple_clear { + my ($self, $me, $name) = @_; + " delete ${me}->{${\quotify $name}}\n" +} + +sub generate_get_default { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_get_default(@_); + ($code, delete $self->{captures}); +} + +sub generate_use_default { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_use_default(@_); + ($code, delete $self->{captures}); +} + +sub _generate_use_default { + my ($self, $me, $name, $spec, $test) = @_; + my $get_value = $self->_generate_get_default($me, $name, $spec); + if ($spec->{coerce}) { + $get_value = $self->_generate_coerce( + $name, $get_value, + $spec->{coerce} + ) + } + $test." ? \n" + .$self->_generate_simple_get($me, $name, $spec)."\n:" + .($spec->{isa} ? + " do {\n my \$value = ".$get_value.";\n" + ." ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n" + ." ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n" + ." }\n" + : ' ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n" + ); +} + +sub _generate_get_default { + my ($self, $me, $name, $spec) = @_; + if (exists $spec->{default}) { + ref $spec->{default} + ? $self->_generate_call_code($name, 'default', $me, $spec->{default}) + : quotify $spec->{default}; + } + else { + "${me}->${\$spec->{builder}}" + } +} + +sub generate_simple_get { + my ($self, @args) = @_; + $self->{captures} = {}; + my $code = $self->_generate_simple_get(@args); + ($code, delete $self->{captures}); +} + +sub _generate_simple_get { + my ($self, $me, $name) = @_; + my $name_str = quotify $name; + "${me}->{${name_str}}"; +} + +sub _generate_set { + my ($self, $name, $spec) = @_; + my ($me, $source) = ('$_[0]', '$_[1]'); + if ($self->is_simple_set($name, $spec)) { + return $self->_generate_simple_set($me, $name, $spec, $source); + } + + my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)}; + if ($coerce) { + $source = $self->_generate_coerce($name, $source, $coerce); + } + if ($isa_check) { + 'scalar do { my $value = '.$source.";\n" + .' ('.$self->_generate_isa_check($name, '$value', $isa_check)."),\n" + .' ('.$self->_generate_simple_set($me, $name, $spec, '$value')."),\n" + .($trigger + ? '('.$self->_generate_trigger($name, $me, '$value', $trigger)."),\n" + : '') + .' ('.$self->_generate_simple_get($me, $name, $spec)."),\n" + ."}"; + } + elsif ($trigger) { + my $set = $self->_generate_simple_set($me, $name, $spec, $source); + "scalar (\n" + . ' ('.$self->_generate_trigger($name, $me, "($set)", $trigger)."),\n" + . ' ('.$self->_generate_simple_get($me, $name, $spec)."),\n" + . ")"; + } + else { + '('.$self->_generate_simple_set($me, $name, $spec, $source).')'; + } +} + +sub generate_coerce { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_coerce(@_); + ($code, delete $self->{captures}); +} + +sub _attr_desc { + my ($name, $init_arg) = @_; + return quotify($name) if !defined($init_arg) or $init_arg eq $name; + return quotify($name).' (constructor argument: '.quotify($init_arg).')'; +} + +sub _generate_coerce { + my ($self, $name, $value, $coerce, $init_arg) = @_; + $self->_wrap_attr_exception( + $name, + "coercion", + $init_arg, + $self->_generate_call_code($name, 'coerce', "${value}", $coerce), + 1, + ); +} + +sub generate_trigger { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_trigger(@_); + ($code, delete $self->{captures}); +} + +sub _generate_trigger { + my ($self, $name, $obj, $value, $trigger) = @_; + $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger); +} + +sub generate_isa_check { + my ($self, @args) = @_; + $self->{captures} = {}; + my $code = $self->_generate_isa_check(@args); + ($code, delete $self->{captures}); +} + +sub _wrap_attr_exception { + my ($self, $name, $step, $arg, $code, $want_return) = @_; + my $prefix = quotify("${step} for "._attr_desc($name, $arg).' failed: '); + "do {\n" + .' local $Method::Generate::Accessor::CurrentAttribute = {'."\n" + .' init_arg => '.quotify($arg).",\n" + .' name => '.quotify($name).",\n" + .' step => '.quotify($step).",\n" + ." };\n" + .($want_return ? ' (my $_return),'."\n" : '') + .' (my $_error), (my $_old_error = $@);'."\n" + ." (eval {\n" + .' ($@ = $_old_error),'."\n" + .' (' + .($want_return ? '$_return ='."\n" : '') + .$code."),\n" + ." 1\n" + ." } or\n" + .' $_error = CORE::ref $@ ? $@ : '.$prefix.'.$@);'."\n" + .' ($@ = $_old_error),'."\n" + .' (defined $_error and CORE::die $_error);'."\n" + .($want_return ? ' $_return;'."\n" : '') + ."}\n" +} + +sub _generate_isa_check { + my ($self, $name, $value, $check, $init_arg) = @_; + $self->_wrap_attr_exception( + $name, + "isa check", + $init_arg, + $self->_generate_call_code($name, 'isa_check', $value, $check) + ); +} + +sub _generate_call_code { + my ($self, $name, $type, $values, $sub) = @_; + $sub = \&{$sub} if blessed($sub); # coderef if blessed + if (my $quoted = quoted_from_sub($sub)) { + my $local = 1; + if ($values eq '@_' || $values eq '$_[0]') { + $local = 0; + $values = '@_'; + } + my $code = $quoted->[1]; + if (my $captures = $quoted->[2]) { + my $cap_name = qq{\$${type}_captures_for_}.sanitize_identifier($name); + $self->{captures}->{$cap_name} = \$captures; + Sub::Quote::inlinify($code, $values, + Sub::Quote::capture_unroll($cap_name, $captures, 6), $local); + } else { + Sub::Quote::inlinify($code, $values, undef, $local); + } + } else { + my $cap_name = qq{\$${type}_for_}.sanitize_identifier($name); + $self->{captures}->{$cap_name} = \$sub; + "${cap_name}->(${values})"; + } +} + +sub _sanitize_name { sanitize_identifier($_[1]) } + +sub generate_populate_set { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_populate_set(@_); + ($code, delete $self->{captures}); +} + +sub _generate_populate_set { + my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_; + + my $has_default = $self->has_eager_default($name, $spec); + if (!($has_default || $test)) { + return ''; + } + if ($has_default) { + my $get_default = $self->_generate_get_default($me, $name, $spec); + $source = + $test + ? "(\n ${test}\n" + ." ? ${source}\n : " + .$get_default + .")" + : $get_default; + } + if ($spec->{coerce}) { + $source = $self->_generate_coerce( + $name, $source, + $spec->{coerce}, $init_arg + ) + } + if ($spec->{isa}) { + $source = 'scalar do { my $value = '.$source.";\n" + .' ('.$self->_generate_isa_check( + $name, '$value', $spec->{isa}, $init_arg + )."),\n" + ." \$value\n" + ."}\n"; + } + my $set = $self->_generate_simple_set($me, $name, $spec, $source); + my $trigger = $spec->{trigger} ? $self->_generate_trigger( + $name, $me, $self->_generate_simple_get($me, $name, $spec), + $spec->{trigger} + ) : undef; + if ($has_default) { + "($set)," . ($trigger && $test ? "($test and $trigger)," : '') . "\n"; + } + else { + "($test and ($set)" . ($trigger ? ", ($trigger)" : '') . "),\n"; + } +} + +sub _generate_core_set { + my ($self, $me, $name, $spec, $value) = @_; + my $name_str = quotify $name; + "${me}->{${name_str}} = ${value}"; +} + +sub _generate_simple_set { + my ($self, $me, $name, $spec, $value) = @_; + my $name_str = quotify $name; + my $simple = $self->_generate_core_set($me, $name, $spec, $value); + + if ($spec->{weak_ref}) { + require Scalar::Util; + my $get = $self->_generate_simple_get($me, $name, $spec); + + # Perl < 5.8.3 can't weaken refs to readonly vars + # (e.g. string constants). This *can* be solved by: + # + # &Internals::SvREADONLY($foo, 0); + # Scalar::Util::weaken($foo); + # &Internals::SvREADONLY($foo, 1); + # + # but requires Internal functions and is just too damn crazy + # so simply throw a better exception + my $weak_simple = _CAN_WEAKEN_READONLY + ? "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }" + : <<"EOC" + ( eval { Scalar::Util::weaken($simple); 1 } + ? do { no warnings 'void'; $get } + : do { + if( \$@ =~ /Modification of a read-only value attempted/) { + require Carp; + Carp::croak( sprintf ( + 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3', + $name_str, + ) ); + } else { + die \$@; + } + } + ) +EOC + } else { + $simple; + } +} + +sub _generate_getset { + my ($self, $name, $spec) = @_; + q{(@_ > 1}."\n ? ".$self->_generate_set($name, $spec) + ."\n : ".$self->_generate_get($name, $spec)."\n )"; +} + +sub _generate_asserter { + my ($self, $name, $spec) = @_; + my $name_str = quotify($name); + "do {\n" + ." my \$val = ".$self->_generate_get($name, $spec).";\n" + ." ".$self->_generate_simple_has('$_[0]', $name, $spec)."\n" + ." or Carp::croak(q{Attempted to access '}.${name_str}.q{' but it is not set});\n" + ." \$val;\n" + ."}\n"; +} +sub _generate_delegation { + my ($self, $asserter, $target, $args) = @_; + my $arg_string = do { + if (@$args) { + # I could, I reckon, linearise out non-refs here using quotify + # plus something to check for numbers but I'm unsure if it's worth it + $self->{captures}{'@curries'} = $args; + '@curries, @_'; + } else { + '@_'; + } + }; + "shift->${asserter}->${target}(${arg_string});"; +} + +sub _generate_xs { + my ($self, $type, $into, $name, $slot) = @_; + Class::XSAccessor->import( + class => $into, + $type => { $name => $slot }, + replace => 1, + ); + $into->can($name); +} + +sub default_construction_string { '{}' } + +sub _validate_codulatable { + my ($self, $setting, $value, $into, $appended) = @_; + + my $error; + + if (blessed $value) { + local $@; + no warnings 'void'; + eval { \&$value; 1 } + and return 1; + $error = "could not be converted to a coderef: $@"; + } + elsif (ref $value eq 'CODE') { + return 1; + } + else { + $error = 'is not a coderef or code-convertible object'; + } + + croak "Invalid $setting '" + . ($INC{'overload.pm'} ? overload::StrVal($value) : $value) + . "' for $into " . $error + . ($appended ? " $appended" : ''); +} + +1; diff --git a/lib/Method/Generate/BuildAll.pm b/lib/Method/Generate/BuildAll.pm new file mode 100644 index 0000000..cabee00 --- /dev/null +++ b/lib/Method/Generate/BuildAll.pm @@ -0,0 +1,42 @@ +package Method::Generate::BuildAll; + +use Moo::_strictures; +use Moo::Object (); +BEGIN { our @ISA = qw(Moo::Object) } +use Sub::Quote qw(quote_sub quotify); +use Moo::_Utils qw(_getglob); +use Moo::_mro; + +sub generate_method { + my ($self, $into) = @_; + quote_sub "${into}::BUILDALL" + => join('', + $self->_handle_subbuild($into), + qq{ my \$self = shift;\n}, + $self->buildall_body_for($into, '$self', '@_'), + qq{ return \$self\n}, + ) + => {} + => { no_defer => 1 } + ; +} + +sub _handle_subbuild { + my ($self, $into) = @_; + ' if (ref($_[0]) ne '.quotify($into).') {'."\n". + ' return shift->Moo::Object::BUILDALL(@_)'.";\n". + ' }'."\n"; +} + +sub buildall_body_for { + my ($self, $into, $me, $args) = @_; + my @builds = + grep *{_getglob($_)}{CODE}, + map "${_}::BUILD", + reverse @{mro::get_linear_isa($into)}; + ' (('.$args.')[0]->{__no_BUILD__} or ('."\n" + .join('', map qq{ ${me}->${_}(${args}),\n}, @builds) + ." )),\n"; +} + +1; diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm new file mode 100644 index 0000000..1ea950b --- /dev/null +++ b/lib/Method/Generate/Constructor.pm @@ -0,0 +1,266 @@ +package Method::Generate::Constructor; + +use Moo::_strictures; +use Sub::Quote qw(quote_sub quotify); +use Sub::Defer; +use Moo::_Utils qw(_getstash _getglob); +use Moo::_mro; +use Scalar::Util qw(weaken); +use Carp qw(croak); +use Carp::Heavy (); +BEGIN { our @CARP_NOT = qw(Sub::Defer) } +BEGIN { + local $Moo::sification::disabled = 1; + require Moo; + Moo->import; +} + +sub register_attribute_specs { + my ($self, @new_specs) = @_; + $self->assert_constructor; + my $specs = $self->{attribute_specs}||={}; + my $ag = $self->accessor_generator; + while (my ($name, $new_spec) = splice @new_specs, 0, 2) { + if ($name =~ s/^\+//) { + croak "has '+${name}' given but no ${name} attribute already exists" + unless my $old_spec = $specs->{$name}; + $ag->merge_specs($new_spec, $old_spec); + } + if ($new_spec->{required} + && !( + $ag->has_default($name, $new_spec) + || !exists $new_spec->{init_arg} + || defined $new_spec->{init_arg} + ) + ) { + croak "You cannot have a required attribute (${name})" + . " without a default, builder, or an init_arg"; + } + $new_spec->{index} = scalar keys %$specs + unless defined $new_spec->{index}; + $specs->{$name} = $new_spec; + } + $self; +} + +sub all_attribute_specs { + $_[0]->{attribute_specs} +} + +sub accessor_generator { + $_[0]->{accessor_generator} +} + +sub construction_string { + my ($self) = @_; + $self->{construction_string} + ||= $self->_build_construction_string; +} + +sub buildall_generator { + require Method::Generate::BuildAll; + Method::Generate::BuildAll->new; +} + +sub _build_construction_string { + my ($self) = @_; + my $builder = $self->{construction_builder}; + $builder ? $self->$builder + : 'bless(' + .$self->accessor_generator->default_construction_string + .', $class);' +} + +sub install_delayed { + my ($self) = @_; + $self->assert_constructor; + my $package = $self->{package}; + my (undef, @isa) = @{mro::get_linear_isa($package)}; + my $isa = join ',', @isa; + my (undef, $from_file, $from_line) = caller(Carp::short_error_loc()); + my $constructor = defer_sub "${package}::new" => sub { + my (undef, @new_isa) = @{mro::get_linear_isa($package)}; + if (join(',', @new_isa) ne $isa) { + my ($expected_new) = grep { *{_getglob($_.'::new')}{CODE} } @isa; + my ($found_new) = grep { *{_getglob($_.'::new')}{CODE} } @new_isa; + if (($found_new||'') ne ($expected_new||'')) { + $found_new ||= 'none'; + $expected_new ||= 'none'; + croak "Expected parent constructor of $package to be" + . " $expected_new, but found $found_new: changing the inheritance" + . " chain (\@ISA) at runtime (after $from_file line $from_line) is unsupported"; + } + } + + my $constructor = $self->generate_method( + $package, 'new', $self->{attribute_specs}, { no_install => 1, no_defer => 1 } + ); + $self->{inlined} = 1; + weaken($self->{constructor} = $constructor); + $constructor; + }; + $self->{inlined} = 0; + weaken($self->{constructor} = $constructor); + $self; +} + +sub current_constructor { + my ($self, $package) = @_; + return *{_getglob("${package}::new")}{CODE}; +} + +sub assert_constructor { + my ($self) = @_; + my $package = $self->{package} or return 1; + my $current = $self->current_constructor($package) + or return 1; + my $constructor = $self->{constructor} + or croak "Unknown constructor for $package already exists"; + croak "Constructor for $package has been replaced with an unknown sub" + if $constructor != $current; + croak "Constructor for $package has been inlined and cannot be updated" + if $self->{inlined}; +} + +sub generate_method { + my ($self, $into, $name, $spec, $quote_opts) = @_; + $quote_opts = { + %{$quote_opts||{}}, + package => $into, + }; + foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) { + $spec->{$no_init}{init_arg} = $no_init; + } + local $self->{captures} = {}; + + my $into_buildargs = $into->can('BUILDARGS'); + + my $body + = ' my $invoker = CORE::shift();'."\n" + . ' my $class = CORE::ref($invoker) ? CORE::ref($invoker) : $invoker;'."\n" + . $self->_handle_subconstructor($into, $name) + . ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS + ? $self->_generate_args_via_buildargs + : $self->_generate_args + ) + . $self->_check_required($spec) + . ' my $new = '.$self->construction_string.";\n" + . $self->_assign_new($spec) + . ( $into->can('BUILD') + ? $self->buildall_generator->buildall_body_for( $into, '$new', '$args' ) + : '' + ) + . ' return $new;'."\n"; + + if ($into->can('DEMOLISH')) { + require Method::Generate::DemolishAll; + Method::Generate::DemolishAll->new->generate_method($into); + } + quote_sub + "${into}::${name}" => $body, + $self->{captures}, $quote_opts||{} + ; +} + +sub _handle_subconstructor { + my ($self, $into, $name) = @_; + if (my $gen = $self->{subconstructor_handler}) { + ' if ($class ne '.quotify($into).') {'."\n". + $gen. + ' }'."\n"; + } else { + '' + } +} + +sub _cap_call { + my ($self, $code, $captures) = @_; + @{$self->{captures}}{keys %$captures} = values %$captures if $captures; + $code; +} + +sub _generate_args_via_buildargs { + my ($self) = @_; + q{ my $args = $class->BUILDARGS(@_);}."\n" + .q{ Carp::croak("BUILDARGS did not return a hashref") unless CORE::ref($args) eq 'HASH';} + ."\n"; +} + +# inlined from Moo::Object - update that first. +sub _generate_args { + my ($self) = @_; + return <<'_EOA'; + my $args = scalar @_ == 1 + ? CORE::ref $_[0] eq 'HASH' + ? { %{ $_[0] } } + : Carp::croak("Single parameters to new() must be a HASH ref" + . " data => ". $_[0]) + : @_ % 2 + ? Carp::croak("The new() method for $class expects a hash reference or a" + . " key/value list. You passed an odd number of arguments") + : {@_} + ; +_EOA + +} + +sub _assign_new { + my ($self, $spec) = @_; + my $ag = $self->accessor_generator; + my %test; + NAME: foreach my $name (sort keys %$spec) { + my $attr_spec = $spec->{$name}; + next NAME unless defined($attr_spec->{init_arg}) + or $ag->has_eager_default($name, $attr_spec); + $test{$name} = $attr_spec->{init_arg}; + } + join '', map { + my $arg = $test{$_}; + my $arg_key = quotify($arg); + my $test = defined $arg ? "exists \$args->{$arg_key}" : undef; + my $source = defined $arg ? "\$args->{$arg_key}" : undef; + my $attr_spec = $spec->{$_}; + $self->_cap_call($ag->generate_populate_set( + '$new', $_, $attr_spec, $source, $test, $arg, + )); + } sort keys %test; +} + +sub _check_required { + my ($self, $spec) = @_; + my @required_init = + map $spec->{$_}{init_arg}, + grep { + my $s = $spec->{$_}; # ignore required if default or builder set + $s->{required} and not($s->{builder} or exists $s->{default}) + } sort keys %$spec; + return '' unless @required_init; + ' if (my @missing = grep !exists $args->{$_}, ' + .join(', ', map quotify($_), @required_init).') {'."\n" + .q{ Carp::croak("Missing required arguments: ".CORE::join(', ', sort @missing));}."\n" + ." }\n"; +} + +# bootstrap our own constructor +sub new { + my $class = shift; + delete _getstash(__PACKAGE__)->{new}; + bless $class->BUILDARGS(@_), $class; +} +Moo->_constructor_maker_for(__PACKAGE__) +->register_attribute_specs( + attribute_specs => { + is => 'ro', + reader => 'all_attribute_specs', + }, + accessor_generator => { is => 'ro' }, + construction_string => { is => 'lazy' }, + construction_builder => { is => 'bare' }, + subconstructor_handler => { is => 'ro' }, + package => { is => 'bare' }, +); +if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) { + Moo::HandleMoose::inject_fake_metaclass_for(__PACKAGE__); +} + +1; diff --git a/lib/Method/Generate/DemolishAll.pm b/lib/Method/Generate/DemolishAll.pm new file mode 100644 index 0000000..e549f30 --- /dev/null +++ b/lib/Method/Generate/DemolishAll.pm @@ -0,0 +1,52 @@ +package Method::Generate::DemolishAll; + +use Moo::_strictures; +use Moo::Object (); +BEGIN { our @ISA = qw(Moo::Object) } +use Sub::Quote qw(quote_sub quotify); +use Moo::_Utils qw(_getglob); +use Moo::_mro; + +sub generate_method { + my ($self, $into) = @_; + quote_sub "${into}::DEMOLISHALL", join '', + $self->_handle_subdemolish($into), + qq{ my \$self = shift;\n}, + $self->demolishall_body_for($into, '$self', '@_'), + qq{ return \$self\n}; + quote_sub "${into}::DESTROY", join '', + q! my $self = shift; + my $e = do { + local $?; + local $@; + require Devel::GlobalDestruction; + eval { + $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction); + }; + $@; + }; + + # fatal warnings+die in DESTROY = bad times (perl rt#123398) + no warnings FATAL => 'all'; + use warnings 'all'; + die $e if $e; # rethrow + !; +} + +sub demolishall_body_for { + my ($self, $into, $me, $args) = @_; + my @demolishers = + grep *{_getglob($_)}{CODE}, + map "${_}::DEMOLISH", + @{mro::get_linear_isa($into)}; + join '', map qq{ ${me}->${_}(${args});\n}, @demolishers; +} + +sub _handle_subdemolish { + my ($self, $into) = @_; + ' if (ref($_[0]) ne '.quotify($into).') {'."\n". + ' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n". + ' }'."\n"; +} + +1; diff --git a/lib/Moo.pm b/lib/Moo.pm new file mode 100644 index 0000000..aa5dc72 --- /dev/null +++ b/lib/Moo.pm @@ -0,0 +1,1083 @@ +package Moo; + +use Moo::_strictures; +use Moo::_mro; +use Moo::_Utils qw( + _getglob + _getstash + _install_coderef + _install_modifier + _load_module + _set_loaded + _unimport_coderefs +); +use Scalar::Util qw(reftype); +use Carp qw(croak); +BEGIN { + our @CARP_NOT = qw( + Method::Generate::Constructor + Method::Generate::Accessor + Moo::sification + Moo::_Utils + Moo::Role + ); +} + +our $VERSION = '2.003004'; +$VERSION =~ tr/_//d; + +require Moo::sification; +Moo::sification->import; + +our %MAKERS; + +sub _install_tracked { + my ($target, $name, $code) = @_; + $MAKERS{$target}{exports}{$name} = $code; + _install_coderef "${target}::${name}" => "Moo::${name}" => $code; +} + +sub import { + my $target = caller; + my $class = shift; + _set_loaded(caller); + + strict->import; + warnings->import; + + if ($INC{'Role/Tiny.pm'} and Role::Tiny->is_role($target)) { + croak "Cannot import Moo into a role"; + } + $MAKERS{$target} ||= {}; + _install_tracked $target => extends => sub { + $class->_set_superclasses($target, @_); + $class->_maybe_reset_handlemoose($target); + return; + }; + _install_tracked $target => with => sub { + require Moo::Role; + Moo::Role->apply_roles_to_package($target, @_); + $class->_maybe_reset_handlemoose($target); + }; + _install_tracked $target => has => sub { + my $name_proto = shift; + my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto; + if (@_ % 2 != 0) { + croak "Invalid options for " . join(', ', map "'$_'", @name_proto) + . " attribute(s): even number of arguments expected, got " . scalar @_; + } + my %spec = @_; + foreach my $name (@name_proto) { + # Note that when multiple attributes specified, each attribute + # needs a separate \%specs hashref + my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec; + $class->_constructor_maker_for($target) + ->register_attribute_specs($name, $spec_ref); + $class->_accessor_maker_for($target) + ->generate_method($target, $name, $spec_ref); + $class->_maybe_reset_handlemoose($target); + } + return; + }; + foreach my $type (qw(before after around)) { + _install_tracked $target => $type => sub { + _install_modifier($target, $type, @_); + return; + }; + } + return if $MAKERS{$target}{is_class}; # already exported into this package + my $stash = _getstash($target); + my @not_methods = map +( + !ref($_) ? *$_{CODE}||() : reftype($_) eq 'CODE' ? $_ : () + ), values %$stash; + @{$MAKERS{$target}{not_methods}={}}{@not_methods} = @not_methods; + $MAKERS{$target}{is_class} = 1; + { + no strict 'refs'; + @{"${target}::ISA"} = do { + require Moo::Object; ('Moo::Object'); + } unless @{"${target}::ISA"}; + } + if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) { + Moo::HandleMoose::inject_fake_metaclass_for($target); + } +} + +sub unimport { + my $target = caller; + _unimport_coderefs($target, $MAKERS{$target}); +} + +sub _set_superclasses { + my $class = shift; + my $target = shift; + foreach my $superclass (@_) { + _load_module($superclass); + if ($INC{'Role/Tiny.pm'} && Role::Tiny->is_role($superclass)) { + croak "Can't extend role '$superclass'"; + } + } + # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA + @{*{_getglob("${target}::ISA")}{ARRAY}} = @_; + if (my $old = delete $Moo::MAKERS{$target}{constructor}) { + $old->assert_constructor; + delete _getstash($target)->{new}; + Moo->_constructor_maker_for($target) + ->register_attribute_specs(%{$old->all_attribute_specs}); + } + elsif (!$target->isa('Moo::Object')) { + Moo->_constructor_maker_for($target); + } + $Moo::HandleMoose::MOUSE{$target} = [ + grep defined, map Mouse::Util::find_meta($_), @_ + ] if Mouse::Util->can('find_meta'); +} + +sub _maybe_reset_handlemoose { + my ($class, $target) = @_; + if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) { + Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target); + } +} + +sub _accessor_maker_for { + my ($class, $target) = @_; + return unless $MAKERS{$target}; + $MAKERS{$target}{accessor} ||= do { + my $maker_class = do { + if (my $m = do { + require Sub::Defer; + if (my $defer_target = + (Sub::Defer::defer_info($target->can('new'))||[])->[0] + ) { + my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/); + $MAKERS{$pkg} && $MAKERS{$pkg}{accessor}; + } else { + undef; + } + }) { + ref($m); + } else { + require Method::Generate::Accessor; + 'Method::Generate::Accessor' + } + }; + $maker_class->new; + } +} + +sub _constructor_maker_for { + my ($class, $target) = @_; + return unless $MAKERS{$target}; + $MAKERS{$target}{constructor} ||= do { + require Method::Generate::Constructor; + + my %construct_opts = ( + package => $target, + accessor_generator => $class->_accessor_maker_for($target), + subconstructor_handler => ( + ' if ($Moo::MAKERS{$class}) {'."\n" + .' if ($Moo::MAKERS{$class}{constructor}) {'."\n" + .' package '.$target.';'."\n" + .' return $invoker->SUPER::new(@_);'."\n" + .' }'."\n" + .' '.$class.'->_constructor_maker_for($class);'."\n" + .' return $invoker->new(@_)'.";\n" + .' } elsif ($INC{"Moose.pm"} and my $meta = Class::MOP::get_metaclass_by_name($class)) {'."\n" + .' return $meta->new_object('."\n" + .' $class->can("BUILDARGS") ? $class->BUILDARGS(@_)'."\n" + .' : $class->Moo::Object::BUILDARGS(@_)'."\n" + .' );'."\n" + .' }'."\n" + ), + ); + + my $con; + my @isa = @{mro::get_linear_isa($target)}; + shift @isa; + no strict 'refs'; + if (my ($parent_new) = grep +(defined &{$_.'::new'}), @isa) { + if ($parent_new eq 'Moo::Object') { + # no special constructor needed + } + elsif (my $makers = $MAKERS{$parent_new}) { + $con = $makers->{constructor}; + $construct_opts{construction_string} = $con->construction_string + if $con; + } + elsif ($parent_new->can('BUILDALL')) { + $construct_opts{construction_builder} = sub { + my $inv = $target->can('BUILDARGS') ? '' : 'Moo::Object::'; + 'do {' + .' my $args = $class->'.$inv.'BUILDARGS(@_);' + .' $args->{__no_BUILD__} = 1;' + .' $invoker->'.$target.'::SUPER::new($args);' + .'}' + }; + } + else { + $construct_opts{construction_builder} = sub { + '$invoker->'.$target.'::SUPER::new(' + .($target->can('FOREIGNBUILDARGS') ? + '$class->FOREIGNBUILDARGS(@_)' : '@_') + .')' + }; + } + } + ($con ? ref($con) : 'Method::Generate::Constructor') + ->new(%construct_opts) + ->install_delayed + ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}}) + } +} + +sub _concrete_methods_of { + my ($me, $class) = @_; + my $makers = $MAKERS{$class}; + # grab class symbol table + my $stash = _getstash($class); + # reverse so our keys become the values (captured coderefs) in case + # they got copied or re-used since + my $not_methods = { reverse %{$makers->{not_methods}||{}} }; + +{ + # grab all code entries that aren't in the not_methods list + map {; + no strict 'refs'; + my $code = exists &{"${class}::$_"} ? \&{"${class}::$_"} : undef; + ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code) + } grep +(!ref($stash->{$_}) || reftype($stash->{$_}) eq 'CODE'), keys %$stash + }; +} + +1; +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Moo - Minimalist Object Orientation (with Moose compatibility) + +=head1 SYNOPSIS + + package Cat::Food; + + use Moo; + use strictures 2; + use namespace::clean; + + sub feed_lion { + my $self = shift; + my $amount = shift || 1; + + $self->pounds( $self->pounds - $amount ); + } + + has taste => ( + is => 'ro', + ); + + has brand => ( + is => 'ro', + isa => sub { + die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ' + }, + ); + + has pounds => ( + is => 'rw', + isa => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 }, + ); + + 1; + +And elsewhere: + + my $full = Cat::Food->new( + taste => 'DELICIOUS.', + brand => 'SWEET-TREATZ', + pounds => 10, + ); + + $full->feed_lion; + + say $full->pounds; + +=head1 DESCRIPTION + +C is an extremely light-weight Object Orientation system. It allows one to +concisely define objects and roles with a convenient syntax that avoids the +details of Perl's object system. C contains a subset of L and is +optimised for rapid startup. + +C avoids depending on any XS modules to allow for simple deployments. The +name C is based on the idea that it provides almost -- but not quite -- +two thirds of L. + +Unlike L this module does not aim at full compatibility with +L's surface syntax, preferring instead to provide full interoperability +via the metaclass inflation capabilities described in L. + +For a full list of the minor differences between L and L's surface +syntax, see L. + +=head1 WHY MOO EXISTS + +If you want a full object system with a rich Metaprotocol, L is +already wonderful. + +But if you don't want to use L, you may not want "less metaprotocol" +like L offers, but you probably want "no metaprotocol", which is what +Moo provides. C is ideal for some situations where deployment or startup +time precludes using L and L: + +=over 2 + +=item a command line or CGI script where fast startup is essential + +=item code designed to be deployed as a single file via L + +=item a CPAN module that may be used by others in the above situations + +=back + +C maintains transparent compatibility with L so if you install and +load L you can use Moo classes and roles in L code without +modification. + +Moo -- Minimal Object Orientation -- aims to make it smooth to upgrade to +L when you need more than the minimal features offered by Moo. + +=head1 MOO AND MOOSE + +If L detects L being loaded, it will automatically register +metaclasses for your L and L packages, so you should be able +to use them in L code without modification. + +L will also create L for +L classes and roles, so that in Moose classes C<< isa => 'MyMooClass' >> +and C<< isa => 'MyMooRole' >> work the same as for L classes and roles. + +Extending a L class or consuming a L will also work. + +Extending a L class or consuming a L will also work. But +note that we don't provide L metaclasses or metaroles so the other way +around doesn't work. This feature exists for L users porting to +L; enabling L users to use L classes is not a priority for us. + +This means that there is no need for anything like L for Moo +code - Moo and Moose code should simply interoperate without problem. To +handle L code, you'll likely need an empty Moo role or class consuming +or extending the L stuff since it doesn't register true L +metaclasses like L does. + +If you need to disable the metaclass creation, add: + + no Moo::sification; + +to your code before Moose is loaded, but bear in mind that this switch is +global and turns the mechanism off entirely so don't put this in library code. + +=head1 MOO AND CLASS::XSACCESSOR + +If a new enough version of L is available, it will be used +to generate simple accessors, readers, and writers for better performance. +Simple accessors are those without lazy defaults, type checks/coercions, or +triggers. Simple readers are those without lazy defaults. Readers and writers +generated by L will behave slightly differently: they will +reject attempts to call them with the incorrect number of parameters. + +=head1 MOO VERSUS ANY::MOOSE + +L will load L normally, and L in a program using +L - which theoretically allows you to get the startup time of L +without disadvantaging L users. + +Sadly, this doesn't entirely work, since the selection is load order dependent +- L's metaclass inflation system explained above in L is +significantly more reliable. + +So if you want to write a CPAN module that loads fast or has only pure perl +dependencies but is also fully usable by L users, you should be using +L. + +For a full explanation, see the article +L which explains +the differing strategies in more detail and provides a direct example of +where L succeeds and L fails. + +=head1 PUBLIC METHODS + +Moo provides several methods to any class using it. + +=head2 new + + Foo::Bar->new( attr1 => 3 ); + +or + + Foo::Bar->new({ attr1 => 3 }); + +The constructor for the class. By default it will accept attributes either as a +hashref, or a list of key value pairs. This can be customized with the +L method. + +=head2 does + + if ($foo->does('Some::Role1')) { + ... + } + +Returns true if the object composes in the passed role. + +=head2 DOES + + if ($foo->DOES('Some::Role1') || $foo->DOES('Some::Class1')) { + ... + } + +Similar to L, but will also return true for both composed roles and +superclasses. + +=head2 meta + + my $meta = Foo::Bar->meta; + my @methods = $meta->get_method_list; + +Returns an object that will behave as if it is a +L object for the class. If you call +anything other than C on it, the object will be transparently +upgraded to a genuine L instance, loading Moose in the +process if required. C itself is a no-op, since we generate +metaclasses that are already immutable, and users converting from Moose had +an unfortunate tendency to accidentally load Moose by calling it. + +=head1 LIFECYCLE METHODS + +There are several methods that you can define in your class to control +construction and destruction of objects. They should be used rather than trying +to modify C or C yourself. + +=head2 BUILDARGS + + around BUILDARGS => sub { + my ( $orig, $class, @args ) = @_; + + return { attr1 => $args[0] } + if @args == 1 && !ref $args[0]; + + return $class->$orig(@args); + }; + + Foo::Bar->new( 3 ); + +This class method is used to transform the arguments to C into a hash +reference of attribute values. + +The default implementation accepts a hash or hash reference of named parameters. +If it receives a single argument that isn't a hash reference it will throw 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. + +=head2 FOREIGNBUILDARGS + + sub FOREIGNBUILDARGS { + my ( $class, $options ) = @_; + return $options->{foo}; + } + +If you are inheriting from a non-Moo class, the arguments passed to the parent +class constructor can be manipulated by defining a C method. +It will receive the same arguments as L, and should return a list +of arguments to pass to the parent class constructor. + +=head2 BUILD + + sub BUILD { + my ($self, $args) = @_; + die "foo and bar cannot be used at the same time" + if exists $args->{foo} && exists $args->{bar}; + } + +On object creation, any C methods in the class's inheritance hierarchy +will be called on the object and given the results of L. They each +will be called in order from the parent classes down to the child, and thus +should not themselves call the parent's method. Typically this is used for +object validation or possibly logging. + +=head2 DEMOLISH + + sub DEMOLISH { + my ($self, $in_global_destruction) = @_; + ... + } + +When an object is destroyed, any C methods in the inheritance +hierarchy will be called on the object. They are given boolean to inform them +if global destruction is in progress, and are called from the child class upwards +to the parent. This is similar to L methods but in the opposite order. + +Note that this is implemented by a C method, which is only created on +on the first construction of an object of your class. This saves on overhead for +classes that are never instantiated or those without C methods. If you +try to define your own C, this will cause undefined results. + +=head1 IMPORTED SUBROUTINES + +=head2 extends + + extends 'Parent::Class'; + +Declares a base class. Multiple superclasses can be passed for multiple +inheritance but please consider using L instead. The class +will be loaded but no errors will be triggered if the class can't be found and +there are already subs in the class. + +Calling extends more than once will REPLACE your superclasses, not add to +them like 'use base' would. + +=head2 with + + with 'Some::Role1'; + +or + + with 'Some::Role1', 'Some::Role2'; + +Composes one or more L (or L) roles into the current +class. An error will be raised if these roles cannot be composed because they +have conflicting method definitions. The roles will be loaded using the same +mechanism as C uses. + +=head2 has + + has attr => ( + is => 'ro', + ); + +Declares an attribute for the class. + + package Foo; + use Moo; + has 'attr' => ( + is => 'ro' + ); + + package Bar; + use Moo; + extends 'Foo'; + has '+attr' => ( + default => sub { "blah" }, + ); + +Using the C<+> notation, it's possible to override an attribute. + + has [qw(attr1 attr2 attr3)] => ( + is => 'ro', + ); + +Using an arrayref with multiple attribute names, it's possible to declare +multiple attributes with the same options. + +The options for C are as follows: + +=over 2 + +=item C + +B, may be C, C, C or C. + +C stands for "read-only" and generates an accessor that dies if you attempt +to write to it - i.e. a getter only - by defaulting C to the name of +the attribute. + +C generates a reader like C, but also sets C to 1 and +C to C<_build_${attribute_name}> to allow on-demand generated +attributes. This feature was my attempt to fix my incompetence when +originally designing C, and is also implemented by +L. There is, however, nothing to stop you +using C and C yourself with C or C - it's just that +this isn't generally a good idea so we don't provide a shortcut for it. + +C stands for "read-write protected" and generates a reader like C, but +also sets C to C<_set_${attribute_name}> for attributes that are +designed to be written from inside of the class, but read-only from outside. +This feature comes from L. + +C stands for "read-write" and generates a normal getter/setter by +defaulting the C to the name of the attribute specified. + +=item C + +Takes a coderef which is used to validate the attribute. Unlike L, Moo +does not include a basic type system, so instead of doing C<< isa => 'Num' >>, +one should do + + use Scalar::Util qw(looks_like_number); + ... + isa => sub { + die "$_[0] is not a number!" unless looks_like_number $_[0] + }, + +Note that the return value for C is discarded. Only if the sub dies does +type validation fail. + +L + +Since L does B run the C check before C if a coercion +subroutine has been supplied, C checks are not structural to your code +and can, if desired, be omitted on non-debug builds (although if this results +in an uncaught bug causing your program to break, the L authors guarantee +nothing except that you get to keep both halves). + +If you want L compatible or L style named types, look at +L. + +To cause your C entries to be automatically mapped to named +L objects (rather than the default behaviour +of creating an anonymous type), set: + + $Moo::HandleMoose::TYPE_MAP{$isa_coderef} = sub { + require MooseX::Types::Something; + return MooseX::Types::Something::TypeName(); + }; + +Note that this example is purely illustrative; anything that returns a +L object or something similar enough to it to +make L happy is fine. + +=item C + +Takes a coderef which is meant to coerce the attribute. The basic idea is to +do something like the following: + + coerce => sub { + $_[0] % 2 ? $_[0] : $_[0] + 1 + }, + +Note that L will always execute your coercion: this is to permit +C entries to be used purely for bug trapping, whereas coercions are +always structural to your code. We do, however, apply any supplied C +check after the coercion has run to ensure that it returned a valid value. + +L + +If the C option is a blessed object providing a C or +C method, then the C option may be set to just C<1>. + +=item C + +Takes a string + + handles => 'RobotRole' + +Where C is a L that defines an interface which +becomes the list of methods to handle. + +Takes a list of methods + + handles => [ qw( one two ) ] + +Takes a hashref + + handles => { + un => 'one', + } + +=item C + +Takes a coderef which will get called any time the attribute is set. This +includes the constructor, but not default or built values. The coderef will be +invoked against the object with the new value as an argument. + +If you set this to just C<1>, it generates a trigger which calls the +C<_trigger_${attr_name}> method on C<$self>. This feature comes from +L. + +Note that Moose also passes the old value, if any; this feature is not yet +supported. + +L + +=item C + +Takes a coderef which will get called with $self as its only argument to +populate an attribute if no value for that attribute was supplied to the +constructor. Alternatively, if the attribute is lazy, C executes when +the attribute is first retrieved if no value has yet been provided. + +If a simple scalar is provided, it will be inlined as a string. Any non-code +reference (hash, array) will result in an error - for that case instead use +a code reference that returns the desired value. + +Note that if your default is fired during new() there is no guarantee that +other attributes have been populated yet so you should not rely on their +existence. + +L + +=item C + +Takes a method name which will return true if an attribute has a value. + +If you set this to just C<1>, the predicate is automatically named +C if your attribute's name does not start with an +underscore, or C<_has_${attr_name_without_the_underscore}> if it does. +This feature comes from L. + +=item C + +Takes a method name which will be called to create the attribute - functions +exactly like default except that instead of calling + + $default->($self); + +Moo will call + + $self->$builder; + +The following features come from L: + +If you set this to just C<1>, the builder is automatically named +C<_build_${attr_name}>. + +If you set this to a coderef or code-convertible object, that variable will be +installed under C<$class::_build_${attr_name}> and the builder set to the same +name. + +=item C + +Takes a method name which will clear the attribute. + +If you set this to just C<1>, the clearer is automatically named +C if your attribute's name does not start with an +underscore, or C<_clear_${attr_name_without_the_underscore}> if it does. +This feature comes from L. + +B If the attribute is C, it will be regenerated from C or +C the next time it is accessed. If it is not lazy, it will be C. + +=item C + +B. Set this if you want values for the attribute to be grabbed +lazily. This is usually a good idea if you have a L which requires +another attribute to be set. + +=item C + +B. Set this if the attribute must be passed on object instantiation. + +=item C + +The name of the method that returns the value of the attribute. If you like +Java style methods, you might set this to C + +=item C + +The value of this attribute will be the name of the method to set the value of +the attribute. If you like Java style methods, you might set this to +C. + +=item C + +B. Set this if you want the reference that the attribute contains to +be weakened. Use this when circular references, which cause memory leaks, are +possible. + +=item C + +Takes the name of the key to look for at instantiation time of the object. A +common use of this is to make an underscored attribute have a non-underscored +initialization name. C means that passing the value in on instantiation +is ignored. + +=item C + +Takes either a coderef or array of coderefs which is meant to transform the +given attributes specifications if necessary when upgrading to a Moose role or +class. You shouldn't need this by default, but is provided as a means of +possible extensibility. + +=back + +=head2 before + + before foo => sub { ... }; + +See L<< Class::Method::Modifiers/before method(s) => sub { ... }; >> for full +documentation. + +=head2 around + + around foo => sub { ... }; + +See L<< Class::Method::Modifiers/around method(s) => sub { ... }; >> for full +documentation. + +=head2 after + + after foo => sub { ... }; + +See L<< Class::Method::Modifiers/after method(s) => sub { ... }; >> for full +documentation. + +=head1 SUB QUOTE AWARE + +L allows us to create coderefs that are "inlineable," +giving us a handy, XS-free speed boost. Any option that is L +aware can take advantage of this. + +To do this, you can write + + use Sub::Quote; + + use Moo; + use namespace::clean; + + has foo => ( + is => 'ro', + isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 }) + ); + +which will be inlined as + + do { + local @_ = ($_[0]->{foo}); + die "Not <3" unless $_[0] < 3; + } + +or to avoid localizing @_, + + has foo => ( + is => 'ro', + isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 }) + ); + +which will be inlined as + + do { + my ($val) = ($_[0]->{foo}); + die "Not <3" unless $val < 3; + } + +See L for more information, including how to pass lexical +captures that will also be compiled into the subroutine. + +=head1 CLEANING UP IMPORTS + +L will not clean up imported subroutines for you; you will have +to do that manually. The recommended way to do this is to declare your +imports first, then C, then C. +Anything imported before L will be scrubbed. +Anything imported or declared after will be still be available. + + package Record; + + use Digest::MD5 qw(md5_hex); + + use Moo; + use namespace::clean; + + has name => (is => 'ro', required => 1); + has id => (is => 'lazy'); + sub _build_id { + my ($self) = @_; + return md5_hex($self->name); + } + + 1; + +If you were to import C after L you would +be able to call C<< ->md5_hex() >> on your C instances (and it +probably wouldn't do what you expect!). + +Ls behave slightly differently. Since their methods are +composed into the consuming class, they can do a little more for you +automatically. As long as you declare your imports before calling +C, those imports and the ones L itself +provides will not be composed into consuming classes so there's usually +no need to use L. + +B:> Older versions of L would +inflate Moo classes to full L classes, losing the benefits of Moo. If +you want to use L with a Moo class, make sure you are +using version 0.16 or newer. + +=head1 INCOMPATIBILITIES WITH MOOSE + +There is no built-in type system. C is verified with a coderef; if you +need complex types, L can provide types, type libraries, and +will work seamlessly with both L and L. L can be +considered the successor to L and provides a similar API, so +that you can write + + use Types::Standard qw(Int); + has days_to_live => (is => 'ro', isa => Int); + +C is not supported in core since the author considers it to be a +bad idea and Moose best practices recommend avoiding it. Meanwhile C or +C are more likely to be able to fulfill your needs. + +There is no meta object. If you need this level of complexity you need +L - Moo is small because it explicitly does not provide a metaprotocol. +However, if you load L, then + + Class::MOP::class_of($moo_class_or_role) + +will return an appropriate metaclass pre-populated by L. + +No support for C, C, C, or C - the author +considers augment to be a bad idea, and override can be translated: + + override foo => sub { + ... + super(); + ... + }; + + around foo => sub { + my ($orig, $self) = (shift, shift); + ... + $self->$orig(@_); + ... + }; + +The C method is not provided by default. The author suggests loading +L into C (via C for example) and +using C<$obj-E$::Dwarn()> instead. + +L only supports coderefs and plain scalars, because passing a hash +or array reference as a default is almost always incorrect since the value is +then shared between all objects using that default. + +C is not supported; you are instead encouraged to use the +C<< is => 'lazy' >> option supported by L and +L. + +C is not supported since the author considers it a bad idea and +it has been considered best practice to avoid it for some time. + +C will show up in a L metaclass created from your class +but is otherwise ignored. Then again, L ignores it as well, so this +is arguably not an incompatibility. + +Since C does not require C to be defined but L does +require it, the metaclass inflation for coerce alone is a trifle insane +and if you attempt to subtype the result will almost certainly break. + +Handling of warnings: when you C we enable strict and warnings, in a +similar way to Moose. The authors recommend the use of C, which +enables FATAL warnings, and several extra pragmas when used in development: +L, L, and L. + +Additionally, L supports a set of attribute option shortcuts intended to +reduce common boilerplate. The set of shortcuts is the same as in the L +module L as of its version 0.009+. So if you: + + package MyClass; + use Moo; + use strictures 2; + +The nearest L invocation would be: + + package MyClass; + + use Moose; + use warnings FATAL => "all"; + use MooseX::AttributeShortcuts; + +or, if you're inheriting from a non-Moose class, + + package MyClass; + + use Moose; + use MooseX::NonMoose; + use warnings FATAL => "all"; + use MooseX::AttributeShortcuts; + +Finally, Moose requires you to call + + __PACKAGE__->meta->make_immutable; + +at the end of your class to get an inlined (i.e. not horribly slow) +constructor. Moo does it automatically the first time ->new is called +on your class. (C is a no-op in Moo to ease migration.) + +An extension L exists to ease translating Moose packages +to Moo by providing a more Moose-like interface. + +=head1 SUPPORT + +Users' IRC: #moose on irc.perl.org + +=for :html +L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org> + +Development and contribution IRC: #web-simple on irc.perl.org + +=for :html +L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org> + +Bugtracker: L + +Git repository: L + +Git browser: L + +=head1 AUTHOR + +mst - Matt S. Trout (cpan:MSTROUT) + +=head1 CONTRIBUTORS + +dg - David Leadbeater (cpan:DGL) + +frew - Arthur Axel "fREW" Schmidt (cpan:FREW) + +hobbs - Andrew Rodland (cpan:ARODLAND) + +jnap - John Napiorkowski (cpan:JJNAPIORK) + +ribasushi - Peter Rabbitson (cpan:RIBASUSHI) + +chip - Chip Salzenberg (cpan:CHIPS) + +ajgb - Alex J. G. Burzyński (cpan:AJGB) + +doy - Jesse Luehrs (cpan:DOY) + +perigrin - Chris Prather (cpan:PERIGRIN) + +Mithaldu - Christian Walde (cpan:MITHALDU) + +ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) + +tobyink - Toby Inkster (cpan:TOBYINK) + +haarg - Graham Knop (cpan:HAARG) + +mattp - Matt Phillips (cpan:MATTP) + +bluefeet - Aran Deltac (cpan:BLUEFEET) + +bubaflub - Bob Kuo (cpan:BUBAFLUB) + +ether = Karen Etheridge (cpan:ETHER) + +=head1 COPYRIGHT + +Copyright (c) 2010-2015 the Moo L and L +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. See L. + +=cut diff --git a/lib/Moo/HandleMoose.pm b/lib/Moo/HandleMoose.pm new file mode 100644 index 0000000..694708b --- /dev/null +++ b/lib/Moo/HandleMoose.pm @@ -0,0 +1,228 @@ +package Moo::HandleMoose; +use Moo::_strictures; +use Moo::_Utils qw(_getstash); +use Sub::Quote qw(quotify); +use Carp qw(croak); + +our %TYPE_MAP; + +our $SETUP_DONE; + +sub import { return if $SETUP_DONE; inject_all(); $SETUP_DONE = 1; } + +sub inject_all { + croak "Can't inflate Moose metaclass with Moo::sification disabled" + if $Moo::sification::disabled; + require Class::MOP; + inject_fake_metaclass_for($_) + for grep $_ ne 'Moo::Object', keys %Moo::MAKERS; + inject_fake_metaclass_for($_) for keys %Moo::Role::INFO; + require Moose::Meta::Method::Constructor; + @Moo::HandleMoose::FakeConstructor::ISA = 'Moose::Meta::Method::Constructor'; + @Moo::HandleMoose::FakeMeta::ISA = 'Moose::Meta::Method::Meta'; +} + +sub maybe_reinject_fake_metaclass_for { + my ($name) = @_; + our %DID_INJECT; + if (delete $DID_INJECT{$name}) { + unless ($Moo::Role::INFO{$name}) { + Moo->_constructor_maker_for($name)->install_delayed; + } + inject_fake_metaclass_for($name); + } +} + +sub inject_fake_metaclass_for { + my ($name) = @_; + require Class::MOP; + require Moo::HandleMoose::FakeMetaClass; + Class::MOP::store_metaclass_by_name( + $name, bless({ name => $name }, 'Moo::HandleMoose::FakeMetaClass') + ); + require Moose::Util::TypeConstraints; + if ($Moo::Role::INFO{$name}) { + Moose::Util::TypeConstraints::find_or_create_does_type_constraint($name); + } else { + Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($name); + } +} + +{ + package Moo::HandleMoose::FakeConstructor; + + sub _uninlined_body { \&Moose::Object::new } +} + +sub inject_real_metaclass_for { + my ($name) = @_; + our %DID_INJECT; + return Class::MOP::get_metaclass_by_name($name) if $DID_INJECT{$name}; + require Moose; require Moo; require Moo::Role; require Scalar::Util; + require Sub::Defer; + Class::MOP::remove_metaclass_by_name($name); + my ($am_role, $am_class, $meta, $attr_specs, $attr_order) = do { + if (my $info = $Moo::Role::INFO{$name}) { + my @attr_info = @{$info->{attributes}||[]}; + (1, 0, Moose::Meta::Role->initialize($name), + { @attr_info }, + [ @attr_info[grep !($_ % 2), 0..$#attr_info] ] + ) + } elsif ( my $cmaker = Moo->_constructor_maker_for($name) ) { + my $specs = $cmaker->all_attribute_specs; + (0, 1, Moose::Meta::Class->initialize($name), $specs, + [ sort { $specs->{$a}{index} <=> $specs->{$b}{index} } keys %$specs ] + ); + } else { + # This codepath is used if $name does not exist in $Moo::MAKERS + (0, 0, Moose::Meta::Class->initialize($name), {}, [] ) + } + }; + + { + local $DID_INJECT{$name} = 1; + foreach my $spec (values %$attr_specs) { + if (my $inflators = delete $spec->{moosify}) { + $_->($spec) for @$inflators; + } + } + + my %methods + = %{($am_role ? 'Moo::Role' : 'Moo')->_concrete_methods_of($name)}; + + # if stuff gets added afterwards, _maybe_reset_handlemoose should + # trigger the recreation of the metaclass but we need to ensure the + # Moo::Role cache is cleared so we don't confuse Moo itself. + if (my $info = $Moo::Role::INFO{$name}) { + delete $info->{methods}; + } + + # needed to ensure the method body is stable and get things named + $methods{$_} = Sub::Defer::undefer_sub($methods{$_}) + for + grep $_ ne 'new', + keys %methods; + my @attrs; + { + # This local is completely not required for roles but harmless + local @{_getstash($name)}{keys %methods}; + my %seen_name; + foreach my $attr_name (@$attr_order) { + $seen_name{$attr_name} = 1; + my %spec = %{$attr_specs->{$attr_name}}; + my %spec_map = ( + map { $_->name => $_->init_arg||$_->name } + ( + (grep { $_->has_init_arg } + $meta->attribute_metaclass->meta->get_all_attributes), + grep { exists($_->{init_arg}) ? defined($_->init_arg) : 1 } + map { + my $meta = Moose::Util::resolve_metatrait_alias('Attribute', $_) + ->meta; + map $meta->get_attribute($_), $meta->get_attribute_list + } @{$spec{traits}||[]} + ) + ); + # have to hard code this because Moose's role meta-model is lacking + $spec_map{traits} ||= 'traits'; + + $spec{is} = 'ro' if $spec{is} eq 'lazy' or $spec{is} eq 'rwp'; + my $coerce = $spec{coerce}; + if (my $isa = $spec{isa}) { + my $tc = $spec{isa} = do { + if (my $mapped = $TYPE_MAP{$isa}) { + my $type = $mapped->(); + unless ( Scalar::Util::blessed($type) + && $type->isa("Moose::Meta::TypeConstraint") ) { + croak "error inflating attribute '$attr_name' for package '$name': " + ."\$TYPE_MAP{$isa} did not return a valid type constraint'"; + } + $coerce ? $type->create_child_type(name => $type->name) : $type; + } else { + Moose::Meta::TypeConstraint->new( + constraint => sub { eval { &$isa; 1 } } + ); + } + }; + if ($coerce) { + $tc->coercion(Moose::Meta::TypeCoercion->new) + ->_compiled_type_coercion($coerce); + $spec{coerce} = 1; + } + } elsif ($coerce) { + my $attr = quotify($attr_name); + my $tc = Moose::Meta::TypeConstraint->new( + constraint => sub { die "This is not going to work" }, + inlined => sub { + 'my $r = $_[42]{'.$attr.'}; $_[42]{'.$attr.'} = 1; $r' + }, + ); + $tc->coercion(Moose::Meta::TypeCoercion->new) + ->_compiled_type_coercion($coerce); + $spec{isa} = $tc; + $spec{coerce} = 1; + } + %spec = + map { $spec_map{$_} => $spec{$_} } + grep { exists $spec_map{$_} } + keys %spec; + push @attrs, $meta->add_attribute($attr_name => %spec); + } + foreach my $mouse (do { our %MOUSE; @{$MOUSE{$name}||[]} }) { + foreach my $attr ($mouse->get_all_attributes) { + my %spec = %{$attr}; + delete @spec{qw( + associated_class associated_methods __METACLASS__ + provides curries + )}; + my $attr_name = delete $spec{name}; + next if $seen_name{$attr_name}++; + push @attrs, $meta->add_attribute($attr_name => %spec); + } + } + } + foreach my $meth_name (keys %methods) { + my $meth_code = $methods{$meth_name}; + $meta->add_method($meth_name, $meth_code); + } + + if ($am_role) { + my $info = $Moo::Role::INFO{$name}; + $meta->add_required_methods(@{$info->{requires}}); + foreach my $modifier (@{$info->{modifiers}}) { + my ($type, @args) = @$modifier; + my $code = pop @args; + $meta->${\"add_${type}_method_modifier"}($_, $code) for @args; + } + } + elsif ($am_class) { + foreach my $attr (@attrs) { + foreach my $method (@{$attr->associated_methods}) { + $method->{body} = $name->can($method->name); + } + } + bless( + $meta->find_method_by_name('new'), + 'Moo::HandleMoose::FakeConstructor', + ); + my $meta_meth; + if ( + $meta_meth = $meta->find_method_by_name('meta') + and $meta_meth->body == \&Moo::Object::meta + ) { + bless($meta_meth, 'Moo::HandleMoose::FakeMeta'); + } + # a combination of Moo and Moose may bypass a Moo constructor but still + # use a Moo DEMOLISHALL. We need to make sure this is loaded before + # global destruction. + require Method::Generate::DemolishAll; + } + $meta->add_role(Class::MOP::class_of($_)) + for grep !/\|/ && $_ ne $name, # reject Foo|Bar and same-role-as-self + keys %{$Moo::Role::APPLIED_TO{$name}} + } + $DID_INJECT{$name} = 1; + $meta; +} + +1; diff --git a/lib/Moo/HandleMoose/FakeMetaClass.pm b/lib/Moo/HandleMoose/FakeMetaClass.pm new file mode 100644 index 0000000..77da3c2 --- /dev/null +++ b/lib/Moo/HandleMoose/FakeMetaClass.pm @@ -0,0 +1,34 @@ +package Moo::HandleMoose::FakeMetaClass; +use Moo::_strictures; +use Carp (); +BEGIN { our @CARP_NOT = qw(Moo::HandleMoose) } + +sub DESTROY { } + +sub AUTOLOAD { + my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/); + my $self = shift; + Carp::croak "Can't call $meth without object instance" + if !ref $self; + Carp::croak "Can't inflate Moose metaclass with Moo::sification disabled" + if $Moo::sification::disabled; + require Moo::HandleMoose; + Moo::HandleMoose::inject_real_metaclass_for($self->{name})->$meth(@_) +} +sub can { + my $self = shift; + return $self->SUPER::can(@_) + if !ref $self or $Moo::sification::disabled; + require Moo::HandleMoose; + Moo::HandleMoose::inject_real_metaclass_for($self->{name})->can(@_) +} +sub isa { + my $self = shift; + return $self->SUPER::isa(@_) + if !ref $self or $Moo::sification::disabled; + require Moo::HandleMoose; + Moo::HandleMoose::inject_real_metaclass_for($self->{name})->isa(@_) +} +sub make_immutable { $_[0] } + +1; diff --git a/lib/Moo/HandleMoose/_TypeMap.pm b/lib/Moo/HandleMoose/_TypeMap.pm new file mode 100644 index 0000000..0dc73c4 --- /dev/null +++ b/lib/Moo/HandleMoose/_TypeMap.pm @@ -0,0 +1,76 @@ +package Moo::HandleMoose::_TypeMap; +use Moo::_strictures; + +package + Moo::HandleMoose; +our %TYPE_MAP; + +package Moo::HandleMoose::_TypeMap; + +use Scalar::Util (); +use Config; + +our %WEAK_TYPES; + +sub _str_to_ref { + my $in = shift; + return $in + if ref $in; + + if ($in =~ /(?:^|=)([A-Z]+)\(0x([0-9a-zA-Z]+)\)$/) { + my $type = $1; + my $id = do { no warnings 'portable'; hex "$2" }; + require B; + my $sv = bless \$id, 'B::SV'; + my $ref = eval { $sv->object_2svref }; + if (!defined $ref or Scalar::Util::reftype($ref) ne $type) { + die <<'END_ERROR'; +Moo initialization encountered types defined in a parent thread - ensure that +Moo is require()d before any further thread spawns following a type definition. +END_ERROR + } + return $ref; + } + return $in; +} + +sub TIEHASH { bless {}, $_[0] } + +sub STORE { + my ($self, $key, $value) = @_; + my $type = _str_to_ref($key); + $WEAK_TYPES{$type} = $type; + Scalar::Util::weaken($WEAK_TYPES{$type}) + if ref $type; + $self->{$key} = $value; +} + +sub FETCH { $_[0]->{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } +sub NEXTKEY { each %{$_[0]} } +sub EXISTS { exists $_[0]->{$_[1]} } +sub DELETE { delete $_[0]->{$_[1]} } +sub CLEAR { %{$_[0]} = () } +sub SCALAR { scalar %{$_[0]} } + +sub CLONE { + my @types = map { + defined $WEAK_TYPES{$_} ? ($WEAK_TYPES{$_} => $TYPE_MAP{$_}) : () + } keys %TYPE_MAP; + %WEAK_TYPES = (); + %TYPE_MAP = @types; +} + +sub DESTROY { + my %types = %{$_[0]}; + untie %TYPE_MAP; + %TYPE_MAP = %types; +} + +if ($Config{useithreads}) { + my @types = %TYPE_MAP; + tie %TYPE_MAP, __PACKAGE__; + %TYPE_MAP = @types; +} + +1; diff --git a/lib/Moo/Object.pm b/lib/Moo/Object.pm new file mode 100644 index 0000000..86b6031 --- /dev/null +++ b/lib/Moo/Object.pm @@ -0,0 +1,77 @@ +package Moo::Object; + +use Moo::_strictures; +use Carp (); + +our %NO_BUILD; +our %NO_DEMOLISH; +our $BUILD_MAKER; +our $DEMOLISH_MAKER; + +sub new { + my $class = shift; + unless (exists $NO_DEMOLISH{$class}) { + unless ($NO_DEMOLISH{$class} = !$class->can('DEMOLISH')) { + ($DEMOLISH_MAKER ||= do { + require Method::Generate::DemolishAll; + Method::Generate::DemolishAll->new + })->generate_method($class); + } + } + my $proto = $class->BUILDARGS(@_); + $NO_BUILD{$class} and + return bless({}, $class); + $NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class}; + $NO_BUILD{$class} + ? bless({}, $class) + : bless({}, $class)->BUILDALL($proto); +} + +# Inlined into Method::Generate::Constructor::_generate_args() - keep in sync +sub BUILDARGS { + my $class = shift; + scalar @_ == 1 + ? ref $_[0] eq 'HASH' + ? { %{ $_[0] } } + : Carp::croak("Single parameters to new() must be a HASH ref" + . " data => ". $_[0]) + : @_ % 2 + ? Carp::croak("The new() method for $class expects a hash reference or a" + . " key/value list. You passed an odd number of arguments") + : {@_} + ; +} + +sub BUILDALL { + my $self = shift; + $self->${\(($BUILD_MAKER ||= do { + require Method::Generate::BuildAll; + Method::Generate::BuildAll->new + })->generate_method(ref($self)))}(@_); +} + +sub DEMOLISHALL { + my $self = shift; + $self->${\(($DEMOLISH_MAKER ||= do { + require Method::Generate::DemolishAll; + Method::Generate::DemolishAll->new + })->generate_method(ref($self)))}(@_); +} + +sub does { + return !!0 + unless ($INC{'Moose/Role.pm'} || $INC{'Role/Tiny.pm'}); + require Moo::Role; + my $does = Moo::Role->can("does_role"); + { no warnings 'redefine'; *does = $does } + goto &$does; +} + +# duplicated in Moo::Role +sub meta { + require Moo::HandleMoose::FakeMetaClass; + my $class = ref($_[0])||$_[0]; + bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass'); +} + +1; diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm new file mode 100644 index 0000000..7ce662c --- /dev/null +++ b/lib/Moo/Role.pm @@ -0,0 +1,550 @@ +package Moo::Role; + +use Moo::_strictures; +use Moo::_Utils qw( + _getglob + _getstash + _install_coderef + _install_modifier + _load_module + _name_coderef + _set_loaded + _unimport_coderefs +); +use Carp qw(croak); +use Role::Tiny (); +BEGIN { our @ISA = qw(Role::Tiny) } +BEGIN { + our @CARP_NOT = qw( + Method::Generate::Accessor + Method::Generate::Constructor + Moo::sification + Moo::_Utils + ); +} + +our $VERSION = '2.003004'; +$VERSION =~ tr/_//d; + +require Moo::sification; +Moo::sification->import; + +BEGIN { + *INFO = \%Role::Tiny::INFO; + *APPLIED_TO = \%Role::Tiny::APPLIED_TO; + *COMPOSED = \%Role::Tiny::COMPOSED; + *ON_ROLE_CREATE = \@Role::Tiny::ON_ROLE_CREATE; +} + +our %INFO; +our %APPLIED_TO; +our %APPLY_DEFAULTS; +our %COMPOSED; +our @ON_ROLE_CREATE; + +sub _install_tracked { + my ($target, $name, $code) = @_; + $INFO{$target}{exports}{$name} = $code; + _install_coderef "${target}::${name}" => "Moo::Role::${name}" => $code; +} + +sub import { + my $target = caller; + if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) { + croak "Cannot import Moo::Role into a Moo class"; + } + _set_loaded(caller); + goto &Role::Tiny::import; +} + +sub _install_subs { + my ($me, $target) = @_; + _install_tracked $target => has => sub { + my $name_proto = shift; + my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto; + if (@_ % 2 != 0) { + croak("Invalid options for " . join(', ', map "'$_'", @name_proto) + . " attribute(s): even number of arguments expected, got " . scalar @_) + } + my %spec = @_; + foreach my $name (@name_proto) { + my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec; + ($INFO{$target}{accessor_maker} ||= do { + require Method::Generate::Accessor; + Method::Generate::Accessor->new + })->generate_method($target, $name, $spec_ref); + push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref; + $me->_maybe_reset_handlemoose($target); + } + }; + # install before/after/around subs + foreach my $type (qw(before after around)) { + _install_tracked $target => $type => sub { + push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ]; + $me->_maybe_reset_handlemoose($target); + }; + } + _install_tracked $target => requires => sub { + push @{$INFO{$target}{requires}||=[]}, @_; + $me->_maybe_reset_handlemoose($target); + }; + _install_tracked $target => with => sub { + $me->apply_roles_to_package($target, @_); + $me->_maybe_reset_handlemoose($target); + }; + *{_getglob("${target}::meta")} = $me->can('meta'); +} + +push @ON_ROLE_CREATE, sub { + my $target = shift; + if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) { + Moo::HandleMoose::inject_fake_metaclass_for($target); + } +}; + +# duplicate from Moo::Object +sub meta { + require Moo::HandleMoose::FakeMetaClass; + my $class = ref($_[0])||$_[0]; + bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass'); +} + +sub unimport { + my $target = caller; + _unimport_coderefs($target, $INFO{$target}); +} + +sub _maybe_reset_handlemoose { + my ($class, $target) = @_; + if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) { + Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target); + } +} + +sub methods_provided_by { + my ($self, $role) = @_; + _load_module($role); + $self->_inhale_if_moose($role); + croak "${role} is not a Moo::Role" unless $self->is_role($role); + return $self->SUPER::methods_provided_by($role); +} + +sub is_role { + my ($self, $role) = @_; + $self->_inhale_if_moose($role); + $self->SUPER::is_role($role); +} + +sub _inhale_if_moose { + my ($self, $role) = @_; + my $meta; + if (!$self->SUPER::is_role($role) + and ( + $INC{"Moose.pm"} + and $meta = Class::MOP::class_of($role) + and ref $meta ne 'Moo::HandleMoose::FakeMetaClass' + and $meta->isa('Moose::Meta::Role') + ) + or ( + Mouse::Util->can('find_meta') + and $meta = Mouse::Util::find_meta($role) + and $meta->isa('Mouse::Meta::Role') + ) + ) { + my $is_mouse = $meta->isa('Mouse::Meta::Role'); + $INFO{$role}{methods} = { + map +($_ => $role->can($_)), + grep $role->can($_), + grep !($is_mouse && $_ eq 'meta'), + grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'), + $meta->get_method_list + }; + $APPLIED_TO{$role} = { + map +($_->name => 1), $meta->calculate_all_roles + }; + $INFO{$role}{requires} = [ $meta->get_required_method_list ]; + $INFO{$role}{attributes} = [ + map +($_ => do { + my $attr = $meta->get_attribute($_); + my $spec = { %{ $is_mouse ? $attr : $attr->original_options } }; + + if ($spec->{isa}) { + require Sub::Quote; + + my $get_constraint = do { + my $pkg = $is_mouse + ? 'Mouse::Util::TypeConstraints' + : 'Moose::Util::TypeConstraints'; + _load_module($pkg); + $pkg->can('find_or_create_isa_type_constraint'); + }; + + my $tc = $get_constraint->($spec->{isa}); + my $check = $tc->_compiled_type_constraint; + my $tc_var = '$_check_for_'.Sub::Quote::sanitize_identifier($tc->name); + + $spec->{isa} = Sub::Quote::quote_sub( + qq{ + &${tc_var} or Carp::croak "Type constraint failed for \$_[0]" + }, + { $tc_var => \$check }, + { + package => $role, + }, + ); + + if ($spec->{coerce}) { + + # Mouse has _compiled_type_coercion straight on the TC object + $spec->{coerce} = $tc->${\( + $tc->can('coercion')||sub { $_[0] } + )}->_compiled_type_coercion; + } + } + $spec; + }), $meta->get_attribute_list + ]; + my $mods = $INFO{$role}{modifiers} = []; + foreach my $type (qw(before after around)) { + # Mouse pokes its own internals so we have to fall back to doing + # the same thing in the absence of the Moose API method + my $map = $meta->${\( + $meta->can("get_${type}_method_modifiers_map") + or sub { shift->{"${type}_method_modifiers"} } + )}; + foreach my $method (keys %$map) { + foreach my $mod (@{$map->{$method}}) { + push @$mods, [ $type => $method => $mod ]; + } + } + } + $INFO{$role}{inhaled_from_moose} = 1; + $INFO{$role}{is_role} = 1; + } +} + +sub _maybe_make_accessors { + my ($self, $target, $role) = @_; + my $m; + if ($INFO{$role} && $INFO{$role}{inhaled_from_moose} + or $INC{"Moo.pm"} + and $m = Moo->_accessor_maker_for($target) + and ref($m) ne 'Method::Generate::Accessor') { + $self->_make_accessors($target, $role); + } +} + +sub _make_accessors_if_moose { + my ($self, $target, $role) = @_; + if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}) { + $self->_make_accessors($target, $role); + } +} + +sub _make_accessors { + my ($self, $target, $role) = @_; + my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do { + require Method::Generate::Accessor; + Method::Generate::Accessor->new + }); + my $con_gen = $Moo::MAKERS{$target}{constructor}; + my @attrs = @{$INFO{$role}{attributes}||[]}; + while (my ($name, $spec) = splice @attrs, 0, 2) { + # needed to ensure we got an index for an arrayref based generator + if ($con_gen) { + $spec = $con_gen->all_attribute_specs->{$name}; + } + $acc_gen->generate_method($target, $name, $spec); + } +} + +sub _undefer_subs { + my ($self, $target, $role) = @_; + if ($INC{'Sub/Defer.pm'}) { + Sub::Defer::undefer_package($role); + } +} + +sub role_application_steps { + qw(_handle_constructor _undefer_subs _maybe_make_accessors), + $_[0]->SUPER::role_application_steps; +} + +sub apply_roles_to_package { + my ($me, $to, @roles) = @_; + foreach my $role (@roles) { + _load_module($role); + $me->_inhale_if_moose($role); + croak "${role} is not a Moo::Role" unless $me->is_role($role); + } + $me->SUPER::apply_roles_to_package($to, @roles); +} + +sub apply_single_role_to_package { + my ($me, $to, $role) = @_; + _load_module($role); + $me->_inhale_if_moose($role); + croak "${role} is not a Moo::Role" unless $me->is_role($role); + $me->SUPER::apply_single_role_to_package($to, $role); +} + +sub create_class_with_roles { + my ($me, $superclass, @roles) = @_; + + my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles); + + return $new_name if $COMPOSED{class}{$new_name}; + + foreach my $role (@roles) { + _load_module($role); + $me->_inhale_if_moose($role); + croak "${role} is not a Moo::Role" unless $me->is_role($role); + } + + my $m; + if ($INC{"Moo.pm"} + and $m = Moo->_accessor_maker_for($superclass) + and ref($m) ne 'Method::Generate::Accessor') { + # old fashioned way time. + @{*{_getglob("${new_name}::ISA")}{ARRAY}} = ($superclass); + $Moo::MAKERS{$new_name} = {is_class => 1}; + $me->apply_roles_to_package($new_name, @roles); + } + else { + $me->SUPER::create_class_with_roles($superclass, @roles); + $Moo::MAKERS{$new_name} = {is_class => 1}; + $me->_handle_constructor($new_name, $_) for @roles; + } + + if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) { + Moo::HandleMoose::inject_fake_metaclass_for($new_name); + } + $COMPOSED{class}{$new_name} = 1; + _set_loaded($new_name, (caller)[1]); + return $new_name; +} + +sub apply_roles_to_object { + my ($me, $object, @roles) = @_; + my $new = $me->SUPER::apply_roles_to_object($object, @roles); + my $class = ref $new; + _set_loaded($class, (caller)[1]); + + my $apply_defaults = exists $APPLY_DEFAULTS{$class} ? $APPLY_DEFAULTS{$class} + : $APPLY_DEFAULTS{$class} = do { + my %attrs = map { @{$INFO{$_}{attributes}||[]} } @roles; + + if ($INC{'Moo.pm'} + and keys %attrs + and my $con_gen = Moo->_constructor_maker_for($class) + and my $m = Moo->_accessor_maker_for($class)) { + + my $specs = $con_gen->all_attribute_specs; + + my %captures; + my $code = join('', + ( map { + my $name = $_; + my $spec = $specs->{$name}; + if ($m->has_eager_default($name, $spec)) { + my ($has, $has_cap) + = $m->generate_simple_has('$_[0]', $name, $spec); + my ($set, $pop_cap) + = $m->generate_use_default('$_[0]', $name, $spec, $has); + + @captures{keys %$has_cap, keys %$pop_cap} + = (values %$has_cap, values %$pop_cap); + "($set),"; + } + else { + (); + } + } sort keys %attrs ), + ); + if ($code) { + require Sub::Quote; + Sub::Quote::quote_sub( + "${class}::_apply_defaults", + "no warnings 'void';\n$code", + \%captures, + { + package => $class, + no_install => 1, + } + ); + } + else { + 0; + } + } + else { + 0; + } + }; + if ($apply_defaults) { + local $Carp::Internal{+__PACKAGE__} = 1; + local $Carp::Internal{$class} = 1; + $new->$apply_defaults; + } + return $new; +} + +sub _composable_package_for { + my ($self, $role) = @_; + my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role; + return $composed_name if $COMPOSED{role}{$composed_name}; + $self->_make_accessors_if_moose($composed_name, $role); + $self->SUPER::_composable_package_for($role); +} + +sub _install_single_modifier { + my ($me, @args) = @_; + _install_modifier(@args); +} + +sub _install_does { + my ($me, $to) = @_; + + # If Role::Tiny actually installed the DOES, give it a name + my $new = $me->SUPER::_install_does($to) or return; + return _name_coderef("${to}::DOES", $new); +} + +sub does_role { + my ($proto, $role) = @_; + return 1 + if Role::Tiny::does_role($proto, $role); + my $meta; + if ($INC{'Moose.pm'} + and $meta = Class::MOP::class_of($proto) + and ref $meta ne 'Moo::HandleMoose::FakeMetaClass' + and $meta->can('does_role') + ) { + return $meta->does_role($role); + } + return 0; +} + +sub _handle_constructor { + my ($me, $to, $role) = @_; + my $attr_info = $INFO{$role} && $INFO{$role}{attributes}; + return unless $attr_info && @$attr_info; + my $info = $INFO{$to}; + my $con = $INC{"Moo.pm"} && Moo->_constructor_maker_for($to); + my %existing + = $info ? @{$info->{attributes} || []} + : $con ? %{$con->all_attribute_specs || {}} + : (); + + my @attr_info = + map { @{$attr_info}[$_, $_+1] } + grep { ! $existing{$attr_info->[$_]} } + map { 2 * $_ } 0..@$attr_info/2-1; + + if ($info) { + push @{$info->{attributes}||=[]}, @attr_info; + } + elsif ($con) { + # shallow copy of the specs since the constructor will assign an index + $con->register_attribute_specs(map ref() ? { %$_ } : $_, @attr_info); + } +} + +1; +__END__ + +=head1 NAME + +Moo::Role - Minimal Object Orientation support for Roles + +=head1 SYNOPSIS + + package My::Role; + + use Moo::Role; + use strictures 2; + + sub foo { ... } + + sub bar { ... } + + has baz => ( + is => 'ro', + ); + + 1; + +And elsewhere: + + package Some::Class; + + use Moo; + use strictures 2; + + # bar gets imported, but not foo + with('My::Role'); + + sub foo { ... } + + 1; + +=head1 DESCRIPTION + +C builds upon L, so look there for most of the +documentation on how this works. The main addition here is extra bits to make +the roles more "Moosey;" which is to say, it adds L. + +=head1 IMPORTED SUBROUTINES + +See L for all the other subroutines that are +imported by this module. + +=head2 has + + has attr => ( + is => 'ro', + ); + +Declares an attribute for the class to be composed into. See +L for all options. + +=head1 CLEANING UP IMPORTS + +L cleans up its own imported methods and any imports +declared before the C statement automatically. +Anything imported after C will be composed into +consuming packages. A package that consumes this role: + + package My::Role::ID; + + use Digest::MD5 qw(md5_hex); + use Moo::Role; + use Digest::SHA qw(sha1_hex); + + requires 'name'; + + sub as_md5 { my ($self) = @_; return md5_hex($self->name); } + sub as_sha1 { my ($self) = @_; return sha1_hex($self->name); } + + 1; + +..will now have a C<< $self->sha1_hex() >> method available to it +that probably does not do what you expect. On the other hand, a call +to C<< $self->md5_hex() >> will die with the helpful error message: +C. + +See L for more details. + +=head1 SUPPORT + +See L for support and contact information. + +=head1 AUTHORS + +See L for authors. + +=head1 COPYRIGHT AND LICENSE + +See L for the copyright and license. + +=cut diff --git a/lib/Moo/_Utils.pm b/lib/Moo/_Utils.pm new file mode 100644 index 0000000..c9c1370 --- /dev/null +++ b/lib/Moo/_Utils.pm @@ -0,0 +1,127 @@ +package Moo::_Utils; +use Moo::_strictures; + +{ + no strict 'refs'; + sub _getglob { \*{$_[0]} } + sub _getstash { \%{"$_[0]::"} } +} + +BEGIN { + my ($su, $sn); + $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname + or $sn = $INC{'Sub/Name.pm'} + or $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname + or $sn = eval { require Sub::Name; }; + + *_subname = $su ? \&Sub::Util::set_subname + : $sn ? \&Sub::Name::subname + : sub { $_[1] }; + *_CAN_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0}; +} + +use Module::Runtime qw(use_package_optimistically module_notional_filename); + +use Devel::GlobalDestruction (); +use Exporter qw(import); +use Config; +use Carp qw(croak); + +our @EXPORT = qw( + _getglob _install_modifier _load_module _maybe_load_module + _getstash _install_coderef _name_coderef + _unimport_coderefs _set_loaded +); + +sub _install_modifier { + my ($into, $type, $name, $code) = @_; + + if ($INC{'Sub/Defer.pm'} and my $to_modify = $into->can($name)) { # CMM will throw for us if not + Sub::Defer::undefer_sub($to_modify); + } + + require Class::Method::Modifiers; + Class::Method::Modifiers::install_modifier(@_); +} + +sub _load_module { + my $module = $_[0]; + my $file = eval { module_notional_filename($module) } or croak $@; + use_package_optimistically($module); + return 1 + if $INC{$file}; + my $error = $@ || "Can't locate $file"; + + # can't just ->can('can') because a sub-package Foo::Bar::Baz + # creates a 'Baz::' key in Foo::Bar's symbol table + my $stash = _getstash($module)||{}; + return 1 if grep +(ref($_) || *$_{CODE}), values %$stash; + return 1 + if $INC{"Moose.pm"} && Class::MOP::class_of($module) + or Mouse::Util->can('find_meta') && Mouse::Util::find_meta($module); + croak $error; +} + +our %MAYBE_LOADED; +sub _maybe_load_module { + my $module = $_[0]; + return $MAYBE_LOADED{$module} + if exists $MAYBE_LOADED{$module}; + if(! eval { use_package_optimistically($module) }) { + warn "$module exists but failed to load with error: $@"; + } + elsif ( $INC{module_notional_filename($module)} ) { + return $MAYBE_LOADED{$module} = 1; + } + return $MAYBE_LOADED{$module} = 0; +} + +sub _set_loaded { + $INC{Module::Runtime::module_notional_filename($_[0])} ||= $_[1]; +} + +sub _install_coderef { + my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_)); + no warnings 'redefine'; + if (*{$glob}{CODE}) { + *{$glob} = $code; + } + # perl will sometimes warn about mismatched prototypes coming from the + # inheritance cache, so disable them if we aren't redefining a sub + else { + no warnings 'prototype'; + *{$glob} = $code; + } +} + +sub _name_coderef { + shift if @_ > 2; # three args is (target, name, sub) + _CAN_SUBNAME ? _subname(@_) : $_[1]; +} + +sub _unimport_coderefs { + my ($target, $info) = @_; + return unless $info and my $exports = $info->{exports}; + my %rev = reverse %$exports; + my $stash = _getstash($target); + foreach my $name (keys %$exports) { + if ($stash->{$name} and defined(&{$stash->{$name}})) { + if ($rev{$target->can($name)}) { + my $old = delete $stash->{$name}; + my $full_name = join('::',$target,$name); + # Copy everything except the code slot back into place (e.g. $has) + foreach my $type (qw(SCALAR HASH ARRAY IO)) { + next unless defined(*{$old}{$type}); + no strict 'refs'; + *$full_name = *{$old}{$type}; + } + } + } + } +} + +if ($Config{useithreads}) { + require Moo::HandleMoose::_TypeMap; +} + +1; diff --git a/lib/Moo/_mro.pm b/lib/Moo/_mro.pm new file mode 100644 index 0000000..b0d69b4 --- /dev/null +++ b/lib/Moo/_mro.pm @@ -0,0 +1,10 @@ +package Moo::_mro; +use Moo::_strictures; + +if ("$]" >= 5.010_000) { + require mro; +} else { + require MRO::Compat; +} + +1; diff --git a/lib/Moo/_strictures.pm b/lib/Moo/_strictures.pm new file mode 100644 index 0000000..97ce92a --- /dev/null +++ b/lib/Moo/_strictures.pm @@ -0,0 +1,19 @@ +package Moo::_strictures; +use strict; +use warnings; + +sub import { + if ($ENV{MOO_FATAL_WARNINGS}) { + require strictures; + strictures->VERSION(2); + @_ = ('strictures'); + goto &strictures::import; + } + else { + strict->import; + warnings->import; + warnings->unimport('once'); + } +} + +1; diff --git a/lib/Moo/sification.pm b/lib/Moo/sification.pm new file mode 100644 index 0000000..9b837ad --- /dev/null +++ b/lib/Moo/sification.pm @@ -0,0 +1,34 @@ +package Moo::sification; + +use Moo::_strictures; +no warnings 'once'; +use Devel::GlobalDestruction qw(in_global_destruction); +use Carp qw(croak); +BEGIN { our @CARP_NOT = qw(Moo::HandleMoose) } + +sub unimport { + croak "Can't disable Moo::sification after inflation has been done" + if $Moo::HandleMoose::SETUP_DONE; + our $disabled = 1; +} + +sub Moo::HandleMoose::AuthorityHack::DESTROY { + unless (our $disabled or in_global_destruction) { + require Moo::HandleMoose; + Moo::HandleMoose->import; + } +} + +sub import { + return + if our $setup_done; + if ($INC{"Moose.pm"}) { + require Moo::HandleMoose; + Moo::HandleMoose->import; + } else { + $Moose::AUTHORITY = bless({}, 'Moo::HandleMoose::AuthorityHack'); + } + $setup_done = 1; +} + +1; diff --git a/lib/oo.pm b/lib/oo.pm new file mode 100644 index 0000000..0ce8179 --- /dev/null +++ b/lib/oo.pm @@ -0,0 +1,65 @@ +package oo; + +use Moo::_strictures; +use Moo::_Utils qw(_load_module); + +sub moo { + print <<'EOMOO'; + ______ +< Moo! > + ------ + \ ^__^ + \ (oo)\_______ + (__)\ )\/\ + ||----w | + || || +EOMOO + exit 0; +} + +BEGIN { + my $package; + sub import { + moo() if $0 eq '-'; + $package = $_[1] || 'Class'; + if ($package =~ /^\+/) { + $package =~ s/^\+//; + _load_module($package); + } + } + use Filter::Simple sub { s/^/package $package;\nuse Moo;\n/; } +} + +1; +__END__ + +=head1 NAME + +oo - syntactic sugar for Moo oneliners + +=head1 SYNOPSIS + + perl -Moo=Foo -e 'has bar => ( is => q[ro], default => q[baz] ); print Foo->new->bar' + + # loads an existing class and re-"opens" the package definition + perl -Moo=+My::Class -e 'print __PACKAGE__->new->bar' + +=head1 DESCRIPTION + +oo.pm is a simple source filter that adds C to the +beginning of your script, intended for use on the command line via the -M +option. + +=head1 SUPPORT + +See L for support and contact information. + +=head1 AUTHORS + +See L for authors. + +=head1 COPYRIGHT AND LICENSE + +See L for the copyright and license. + +=cut diff --git a/maint/Makefile.PL.include b/maint/Makefile.PL.include new file mode 100644 index 0000000..1a54db0 --- /dev/null +++ b/maint/Makefile.PL.include @@ -0,0 +1,12 @@ +BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } +use lib 'Distar/lib'; +use Distar 0.001; + +use ExtUtils::MakeMaker 6.57_10 (); + +author 'mst - Matt S. Trout (cpan:MSTROUT) '; + +manifest_include t => 'global-destruction-helper.pl'; +manifest_include xt => 'global-destruct-jenga-helper.pl'; + +1; diff --git a/t/accessor-coerce.t b/t/accessor-coerce.t new file mode 100644 index 0000000..a5253b5 --- /dev/null +++ b/t/accessor-coerce.t @@ -0,0 +1,216 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +sub run_for { + my $class = shift; + + my $obj = $class->new(plus_three => 1); + + is($obj->plus_three, 4, "initial value set (${class})"); + + $obj->plus_three(4); + + is($obj->plus_three, 7, 'Value changes after set'); +} + +sub run_with_default_for { + my $class = shift; + + my $obj = $class->new(); + + is($obj->plus_three, 4, "initial value set (${class})"); + + $obj->plus_three(4); + + is($obj->plus_three, 7, 'Value changes after set'); +} + + + +{ + package Foo; + + use Moo; + + has plus_three => ( + is => 'rw', + coerce => sub { $_[0] + 3 } + ); +} + +run_for 'Foo'; + +{ + package Bar; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + coerce => quote_sub q{ + my ($x) = @_; + $x + 3 + } + ); +} + +run_for 'Bar'; + +{ + package Baz; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + coerce => quote_sub( + q{ + my ($value) = @_; + $value + $plus + }, + { '$plus' => \3 } + ) + ); +} + +run_for 'Baz'; + +{ + package Biff; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + coerce => quote_sub( + q{ + die 'could not add three!' + }, + ) + ); +} + +like exception { Biff->new(plus_three => 1) }, qr/coercion for "plus_three" failed: could not add three!/, 'Exception properly thrown'; + +{ + package Foo2; + + use Moo; + + has plus_three => ( + is => 'rw', + default => sub { 1 }, + coerce => sub { $_[0] + 3 } + ); +} + +run_with_default_for 'Foo2'; + +{ + package Bar2; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + default => sub { 1 }, + coerce => quote_sub q{ + my ($x) = @_; + $x + 3 + } + ); +} + +run_with_default_for 'Bar2'; + +{ + package Baz2; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + default => sub { 1 }, + coerce => quote_sub( + q{ + my ($value) = @_; + $value + $plus + }, + { '$plus' => \3 } + ) + ); +} + +run_with_default_for 'Baz2'; + +{ + package Biff2; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + default => sub { 1 }, + coerce => quote_sub( + q{ + die 'could not add three!' + }, + ) + ); +} + +like exception { Biff2->new() }, qr/could not add three!/, 'Exception properly thrown'; + +{ + package Foo3; + + use Moo; + + has plus_three => ( + is => 'rw', + default => sub { 1 }, + coerce => sub { $_[0] + 3 }, + lazy => 1, + ); +} + +run_with_default_for 'Foo3'; + +{ + package Bar3; + + use Sub::Quote; + use Moo; + + has plus_three => ( + is => 'rw', + default => sub { 1 }, + coerce => quote_sub(q{ + my ($x) = @_; + $x + 3 + }), + lazy => 1, + ); +} + +run_with_default_for 'Bar3'; + +{ + package CoerceWriter; + use Moo; + has attr => ( + is => 'rwp', + coerce => sub { die 'triggered' }, + ); +} +like exception { CoerceWriter->new->_set_attr( 4 ) }, + qr/triggered/, "coerce triggered via writer"; + +done_testing; diff --git a/t/accessor-default.t b/t/accessor-default.t new file mode 100644 index 0000000..c1411ee --- /dev/null +++ b/t/accessor-default.t @@ -0,0 +1,109 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +my $c_ran; +{ + package Foo; + + use Sub::Quote; + use Moo; + + has one => (is => 'ro', lazy => 1, default => quote_sub q{ {} }); + has two => (is => 'ro', lazy => 1, builder => '_build_two'); + sub _build_two { {} } + has three => (is => 'ro', default => quote_sub q{ {} }); + has four => (is => 'ro', builder => '_build_four'); + sub _build_four { {} } + has five => (is => 'ro', init_arg => undef, default => sub { {} }); + has six => (is => 'ro', builder => 1); + sub _build_six { {} } + has seven => (is => 'ro', required => 1, default => quote_sub q{ {} }); + has eight => (is => 'ro', builder => '_build_eight', coerce => sub { $c_ran = 1; $_[0] }); + sub _build_eight { {} } + has nine => (is => 'lazy', coerce => sub { $c_ran = 1; $_[0] }); + sub _build_nine { {} } + has ten => (is => 'lazy', default => 5 ); + has eleven => (is => 'ro', default => 5 ); + has twelve => (is => 'lazy', default => 0 ); + has thirteen => (is => 'ro', default => 0 ); + has fourteen => (is => 'ro', required => 1, builder => '_build_fourteen'); + sub _build_fourteen { {} } + has fifteen => (is => 'lazy', default => undef); + + # DIE handler was leaking into defaults when coercion is on. + has default_with_coerce => ( + is => 'rw', + coerce => sub { return $_[0] }, + default => sub { eval { die "blah\n" }; return $@; } + ); + + has default_no_coerce => ( + is => 'rw', + default => sub { eval { die "blah\n" }; return $@; } + ); +} + +sub check { + my ($attr, @h) = @_; + + is_deeply($h[$_], {}, "${attr}: empty hashref \$h[$_]") for 0..1; + + isnt($h[0],$h[1], "${attr}: not the same hashref"); +} + +check one => map Foo->new->one, 1..2; + +check two => map Foo->new->two, 1..2; + +check three => map Foo->new->{three}, 1..2; + +check four => map Foo->new->{four}, 1..2; + +check five => map Foo->new->{five}, 1..2; + +check six => map Foo->new->{six}, 1..2; + +check seven => map Foo->new->{seven}, 1..2; + +check fourteen => map Foo->new->{fourteen}, 1..2; + +check eight => map Foo->new->{eight}, 1..2; +ok($c_ran, 'coerce defaults'); + +$c_ran = 0; + +check nine => map Foo->new->nine, 1..2; +ok($c_ran, 'coerce lazy default'); + +is(Foo->new->ten, 5, 'non-ref default'); +is(Foo->new->eleven, 5, 'eager non-ref default'); +is(Foo->new->twelve, 0, 'false non-ref default'); +is(Foo->new->thirteen, 0, 'eager false non-ref default'); +my $foo = Foo->new; +is($foo->fifteen, undef, 'undef default'); +ok(exists $foo->{fifteen}, 'undef default is stored'); + +is( Foo->new->default_with_coerce, "blah\n", + "exceptions in defaults not modified with coerce" ); +is( Foo->new->default_no_coerce, "blah\n", + "exceptions in defaults not modified without coerce" ); + +{ + package Bar; + use Moo; + has required_false_default => (is => 'ro', required => 1, default => 0); + + ::is ::exception { + has required_is_lazy_no_init_arg => ( + is => 'lazy', + required => 1, + init_arg => undef, + ); + }, undef, 'is => lazy satisfies requires'; +} + +is exception { Bar->new }, undef, + 'required attributes with false defaults work'; + +done_testing; diff --git a/t/accessor-generator-extension.t b/t/accessor-generator-extension.t new file mode 100644 index 0000000..614e267 --- /dev/null +++ b/t/accessor-generator-extension.t @@ -0,0 +1,159 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package Method::Generate::Accessor::Role::ArrayRefInstance; + + use Moo::Role; + + sub _generate_simple_get { + my ($self, $me, $name, $spec) = @_; + "${me}->[${\$spec->{index}}]"; + } + + sub _generate_core_set { + my ($self, $me, $name, $spec, $value) = @_; + "${me}->[${\$spec->{index}}] = $value"; + } + + sub _generate_simple_has { + my ($self, $me, $name, $spec) = @_; + "defined ${me}->[${\$spec->{index}}]"; + } + + sub _generate_simple_clear { + my ($self, $me, $name, $spec) = @_; + "undef(${me}->[${\$spec->{index}}])"; + } + + sub generate_multi_set { + my ($self, $me, $to_set, $from, $specs) = @_; + "\@{${me}}[${\join ', ', map $specs->{$_}{index}, @$to_set}] = $from"; + } + + sub _generate_xs { + my ($self, $type, $into, $name, $slot, $spec) = @_; + require Class::XSAccessor::Array; + Class::XSAccessor::Array->import( + class => $into, + $type => { $name => $spec->{index} } + ); + $into->can($name); + } + + sub default_construction_string { '[]' } + + sub MooX::ArrayRef::import { + Moo::Role->apply_roles_to_object( + Moo->_accessor_maker_for(scalar caller), + 'Method::Generate::Accessor::Role::ArrayRefInstance' + ); + } + $INC{"MooX/ArrayRef.pm"} = 1; +} + +{ + package ArrayTest1; + + use Moo; + use MooX::ArrayRef; + + has one => (is => 'ro'); + has two => (is => 'ro'); + has three => (is => 'ro'); +} + +my $o = ArrayTest1->new(one => 1, two => 2, three => 3); + +is_deeply([ @$o ], [ 1, 2, 3 ], 'Basic object ok'); + +{ + package ArrayTest2; + + use Moo; + + extends 'ArrayTest1'; + + has four => (is => 'ro'); +} + +$o = ArrayTest2->new(one => 1, two => 2, three => 3, four => 4); + +is_deeply([ @$o ], [ 1, 2, 3, 4 ], 'Subclass object ok'); + +{ + package ArrayTestRole; + + use Moo::Role; + + has four => (is => 'ro'); + + package ArrayTest3; + + use Moo; + + extends 'ArrayTest1'; + + with 'ArrayTestRole'; +} + +$o = ArrayTest3->new(one => 1, two => 2, three => 3, four => 4); + +is_deeply([ @$o ], [ 1, 2, 3, 4 ], 'Subclass object w/role'); + +my $c = Moo::Role->create_class_with_roles('ArrayTest1', 'ArrayTestRole'); + +$o = $c->new(one => 1, two => 2, three => 3, four => 4); + +is_deeply([ @$o ], [ 1, 2, 3, 4 ], 'Generated subclass object w/role'); + +is exception { + Moo::Role->create_class_with_roles('ArrayTest1', 'ArrayTestRole'); +}, undef, + 'creating class with role again'; + +{ + package ArrayNonMoo; + sub new { bless [], $_[0] } +} + +{ + package ArrayTest4; + + use Moo; + use MooX::ArrayRef; + + extends 'ArrayNonMoo'; + + has one => (is => 'ro'); + has two => (is => 'ro'); + has three => (is => 'ro'); + has four => (is => 'ro'); +} + +$o = ArrayTest4->new(one => 1, two => 2, three => 3, four => 4); + +is_deeply([ @$o ], [ 1, 2, 3, 4 ], 'Subclass of non-Moo object'); + + +{ + package ArrayTestRole2; + use Moo::Role; + + has four => (is => 'ro'); +} + +{ + my ($new_c) = Moo::Role->_composite_name('ArrayTest1', 'ArrayTestRole2'); + { + no strict 'refs'; + # cause ISA to exist somehow + @{"${new_c}::ISA"} = (); + } + my $c = Moo::Role->create_class_with_roles('ArrayTest1', 'ArrayTestRole2'); + is_deeply mro::get_linear_isa($c), [$c, 'ArrayTest1', 'Moo::Object'], + 'mro::get_linear_isa is correct if create_class_with_roles target class @ISA existed'; +} + +done_testing; diff --git a/t/accessor-handles.t b/t/accessor-handles.t new file mode 100644 index 0000000..af5af9e --- /dev/null +++ b/t/accessor-handles.t @@ -0,0 +1,129 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use lib "t/lib"; + +{ + package Baz; + use Moo; + sub beep {'beep'} + + sub is_passed_undefined { !defined($_[0]) ? 'bar' : 'fail' } +} + +{ + package Robot; + + use Moo::Role; + + requires 'smash'; + $INC{"Robot.pm"} = 1; + +} + +{ + package Foo; + + use Moo; + + with 'Robot'; + + sub one {1} + sub two {2} + sub smash {'smash'} + sub yum {$_[1]} +} + +use InlineModule ( + ExtRobot => q{ + package ExtRobot; + + use Moo::Role; + + requires 'beep'; + + 1; + }, +); + +{ + package Bar; + + use Moo; + + has foo => ( is => 'ro', handles => [ qw(one two) ] ); + has foo2 => ( is => 'ro', handles => { un => 'one' } ); + has foo3 => ( is => 'ro', handles => 'Robot' ); + has foo4 => ( is => 'ro', handles => { + eat_curry => [ yum => 'Curry!' ], + }); + has foo5 => ( is => 'ro', handles => 'ExtRobot' ); + has foo6 => ( is => 'rw', + handles => { foobot => '${\\Baz->can("beep")}'}, + default => sub { 0 } ); + has foo7 => ( is => 'rw', + handles => { foobar => '${\\Baz->can("is_passed_undefined")}'}, + default => sub { undef } ); + + has foo8 => ( + is => 'rw', + handles => [ 'foo8_gone' ], + ); +} + +my $bar = Bar->new( + foo => Foo->new, foo2 => Foo->new, foo3 => Foo->new, foo4 => Foo->new, + foo5 => Baz->new +); + +is $bar->one, 1, 'handles works'; +is $bar->two, 2, 'handles works for more than one method'; + +is $bar->un, 1, 'handles works for aliasing a method'; + +is $bar->smash, 'smash', 'handles works for a role'; + +is $bar->beep, 'beep', 'handles loads roles'; + +is $bar->eat_curry, 'Curry!', 'handles works for currying'; + +is $bar->foobot, 'beep', 'asserter checks for existence not truth, on false value'; + +is $bar->foobar, 'bar', 'asserter checks for existence not truth, on undef '; + +like exception { + $bar->foo8_gone; +}, qr/^Attempted to access 'foo8' but it is not set/, + 'asserter fails with correct message'; + +ok(my $e = exception { + package Baz; + use Moo; + has foo => ( is => 'ro', handles => 'Robot' ); + sub smash { 1 }; +}, 'handles will not overwrite locally defined method'); +like $e, qr{You cannot overwrite a locally defined method \(smash\) with a delegation}, + '... and has correct error message'; + +is exception { + package Buzz; + use Moo; + has foo => ( is => 'ro', handles => 'Robot' ); + sub smash; +}, undef, 'handles can overwrite predeclared subs'; + +ok(exception { + package Fuzz; + use Moo; + has foo => ( is => 'ro', handles => $bar ); +}, 'invalid handles (object) throws exception'); + +like exception { + package Borf; + use Moo; + has foo => ( is => 'ro', handles => 'Bar' ); +}, qr/is not a Moo::Role/, + 'invalid handles (class) throws exception'; + +done_testing; diff --git a/t/accessor-isa.t b/t/accessor-isa.t new file mode 100644 index 0000000..92130dc --- /dev/null +++ b/t/accessor-isa.t @@ -0,0 +1,238 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +sub run_for { + my $class = shift; + + my $obj = $class->new(less_than_three => 1); + + is($obj->less_than_three, 1, "initial value set (${class})"); + + like( + exception { $obj->less_than_three(4) }, + qr/isa check for "less_than_three" failed: 4 is not less than three/, + "exception thrown on bad set (${class})" + ); + + is($obj->less_than_three, 1, "initial value remains after bad set (${class})"); + + my $ret; + + is( + exception { $ret = $obj->less_than_three(2) }, + undef, "no exception on correct set (${class})" + ); + + is($ret, 2, "correct setter return (${class})"); + is($obj->less_than_three, 2, "correct getter return (${class})"); + + is(exception { $class->new }, undef, "no exception with no value (${class})"); + like( + exception { $class->new(less_than_three => 12) }, + qr/isa check for "less_than_three" failed: 12 is not less than three/, + "exception thrown on bad constructor arg (${class})" + ); +} + +{ + package Foo; + + use Moo; + + has less_than_three => ( + is => 'rw', + isa => sub { die "$_[0] is not less than three" unless $_[0] < 3 } + ); +} + +run_for 'Foo'; + +{ + package Bar; + + use Sub::Quote; + use Moo; + + has less_than_three => ( + is => 'rw', + isa => quote_sub q{ + my ($x) = @_; + die "$x is not less than three" unless $x < 3 + } + ); +} + +run_for 'Bar'; + +{ + package Baz; + + use Sub::Quote; + use Moo; + + has less_than_three => ( + is => 'rw', + isa => quote_sub( + q{ + my ($value) = @_; + die "$value is not less than ${word}" unless $value < $limit + }, + { '$limit' => \3, '$word' => \'three' } + ) + ); +} + +run_for 'Baz'; + +my $lt3; + +{ + package LazyFoo; + + use Sub::Quote; + use Moo; + + has less_than_three => ( + is => 'lazy', + isa => quote_sub(q{ die "$_[0] is not less than three" unless $_[0] < 3 }) + ); + + sub _build_less_than_three { $lt3 } +} + +$lt3 = 4; + +my $lazyfoo = LazyFoo->new; +like( + exception { $lazyfoo->less_than_three }, + qr/isa check for "less_than_three" failed: 4 is not less than three/, + "exception thrown on bad builder return value (LazyFoo)" +); + +$lt3 = 2; + +is( + exception { $lazyfoo->less_than_three }, + undef, + 'Corrected builder value on existing object returned ok' +); + +is(LazyFoo->new->less_than_three, 2, 'Correct builder value returned ok'); + +{ + package Fizz; + + use Moo; + + has attr1 => ( + is => 'ro', + isa => sub { + no warnings 'once'; + my $attr = $Method::Generate::Accessor::CurrentAttribute; + die bless [@$attr{'name', 'init_arg', 'step'}], 'MyException'; + }, + init_arg => 'attr_1', + ); +} + +my $e = exception { Fizz->new(attr_1 => 5) }; +is( + ref($e), + 'MyException', + 'Exception objects passed though correctly', +); + +is($e->[0], 'attr1', 'attribute name available in isa check'); +is($e->[1], 'attr_1', 'attribute init_arg available in isa check'); +is($e->[2], 'isa check', 'step available in isa check'); + +{ + my $called; + local $SIG{__DIE__} = sub { $called++; die $_[0] }; + my $e = exception { Fizz->new(attr_1 => 5) }; + ok($called, '__DIE__ handler called if set') +} + +{ + package ClassWithDeadlyIsa; + use Moo; + has foo => (is => 'ro', isa => sub { die "nope" }); + + package ClassUsingDeadlyIsa; + use Moo; + has bar => (is => 'ro', coerce => sub { ClassWithDeadlyIsa->new(foo => $_[0]) }); +} + +like exception { ClassUsingDeadlyIsa->new(bar => 1) }, + qr/isa check for "foo" failed: nope/, + 'isa check within isa check produces correct exception'; + +{ + package IsaWriter; + use Moo; + has attr => ( + is => 'rwp', + isa => sub { die 'triggered' }, + ); +} +like exception { IsaWriter->new->_set_attr( 4 ) }, + qr/triggered/, "isa triggered via writer"; + +{ + package ClassWithEvilDestroy; + sub new { bless {}, $_[0] } + sub DESTROY { + eval { + 1; # nop + }; + } + + package ClassWithEvilException; + use Moo; + has foo => (is => 'rw', isa => sub { + local $@; + die "welp"; + }); + has bar => (is => 'rw', isa => sub { + my $o = ClassWithEvilDestroy->new; + die "welp"; + }); + my $error; + has baz => (is => 'rw', isa => sub { + ::is $@, $error, '$@ unchanged inside isa'; + 1; + }); + + my $o = ClassWithEvilException->new; + + ::like ::exception { $o->foo(1) }, qr/isa check for "foo" failed:/, + 'got proper exception with localized $@'; + ::like ::exception { $o->bar(1) }, qr/isa check for "bar" failed:/, + 'got proper exception with eval in DESTROY'; + + eval { die "blah\n" }; + $error = $@; + $o->baz(1); + ::is $@, $error, '$@ unchanged after successful isa'; +} + +{ + package TestClassWithStub; + use Moo; + sub stub_isa; + + ::is ::exception { has attr1 => (is => 'ro', isa => \&stub_isa); }, undef, + 'stubs allowed for isa checks'; + + eval q{ + sub stub_isa { die "stub isa check"; } + 1; + } or die $@; + + ::like ::exception { __PACKAGE__->new(attr1 => 1) }, + qr/stub isa check/, + 'stub isa works after being defined'; +} + +done_testing; diff --git a/t/accessor-mixed.t b/t/accessor-mixed.t new file mode 100644 index 0000000..46621ce --- /dev/null +++ b/t/accessor-mixed.t @@ -0,0 +1,81 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +my @result; + +{ + package Foo; + + use Moo; + + my @isa = (isa => sub { push @result, 'isa', $_[0] }); + my @trigger = (trigger => sub { push @result, 'trigger', $_[1] }); + sub _mkdefault { + my $val = shift; + (default => sub { push @result, 'default', $val; $val; }) + } + + has a1 => ( + is => 'rw', @isa + ); + has a2 => ( + is => 'rw', @isa, @trigger + ); + has a3 => ( + is => 'rw', @isa, @trigger + ); + has a4 => ( + is => 'rw', @trigger, _mkdefault('a4') + ); + has a5 => ( + is => 'rw', @trigger, _mkdefault('a5') + ); + has a6 => ( + is => 'rw', @isa, @trigger, _mkdefault('a6') + ); + has a7 => ( + is => 'rw', @isa, @trigger, _mkdefault('a7') + ); +} + +my $foo = Foo->new(a1 => 'a1', a2 => 'a2', a4 => 'a4', a6 => 'a6'); + +is_deeply( + \@result, + [ qw(isa a1 isa a2 trigger a2 trigger a4 default a5 isa a6 trigger a6 + default a7 isa a7) ], + 'Stuff fired in expected order' +); + +{ + package Guff; + use Moo; + + sub foo { 1 } + + for my $type (qw(accessor reader writer predicate clearer asserter)) { + my $an = $type =~ /^a/ ? 'an' : 'a'; + ::like ::exception { + has "attr_w_$type" => ( is => 'ro', $type => 'foo' ); + }, + qr/^You cannot overwrite a locally defined method \(foo\) with $an $type/, + "overwriting a sub with $an $type fails"; + } +} + +{ + package NWFG; + use Moo; + ::is ::exception { + has qq{odd"na;me\n} => ( + is => 'bare', + map +($_ => 'attr_'.$_), + qw(accessor reader writer predicate clearer asserter) + ); + }, undef, + 'all accessor methods work with oddly named attribute'; +} + + +done_testing; diff --git a/t/accessor-pred-clear.t b/t/accessor-pred-clear.t new file mode 100644 index 0000000..2d3d9df --- /dev/null +++ b/t/accessor-pred-clear.t @@ -0,0 +1,32 @@ +use Moo::_strictures; +use Test::More; + +{ + package Foo; + + use Moo; + + my @params = (is => 'ro', lazy => 1, default => sub { 3 }); + + has one => (@params, predicate => 'has_one', clearer => 'clear_one'); + + has $_ => (@params, clearer => 1, predicate => 1) for qw( bar _bar ); +} + +my $foo = Foo->new; + +for ( qw( one bar _bar ) ) { + my ($lead, $middle) = ('_' x /^_/, '_' x !/^_/); + my $predicate = $lead . "has$middle$_"; + my $clearer = $lead . "clear$middle$_"; + + ok(!$foo->$predicate, 'empty'); + is($foo->$_, 3, 'lazy default'); + ok($foo->$predicate, 'not empty now'); + is($foo->$clearer, 3, 'clearer returns value'); + ok(!$foo->$predicate, 'clearer empties'); + is($foo->$_, 3, 'default re-fired'); + ok($foo->$predicate, 'not empty again'); +} + +done_testing; diff --git a/t/accessor-reader-writer.t b/t/accessor-reader-writer.t new file mode 100644 index 0000000..9ddc698 --- /dev/null +++ b/t/accessor-reader-writer.t @@ -0,0 +1,80 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +my @result; + +{ + package Foo; + + use Moo; + + has one => ( + is => 'rw', + reader => 'get_one', + writer => 'set_one', + ); + + sub one {'sub'} + + has two => ( + is => 'lazy', + default => sub { 2 }, + reader => 'get_two', + ); + + has three => ( + is => 'rwp', + reader => 'get_three', + writer => 'set_three', + ); +} + +{ + package Bar; + + use Moo; + + has two => ( + is => 'rw', + accessor => 'TWO', + ); +} + +my $foo = Foo->new(one => 'lol'); +my $bar = Bar->new(two => '...'); + +is( $foo->get_one, 'lol', 'reader works' ); +$foo->set_one('rofl'); +is( $foo->get_one, 'rofl', 'writer works' ); +is( $foo->one, 'sub', 'reader+writer = no accessor' ); + +is( $foo->get_two, 2, 'lazy doesn\'t override reader' ); + +is( $foo->can('two'), undef, 'reader+ro = no accessor' ); + +ok( $foo->can('get_three'), 'rwp doesn\'t override reader'); +ok( $foo->can('set_three'), 'rwp doesn\'t override writer'); + +ok( exception { $foo->get_one('blah') }, 'reader dies on write' ); + +is( $bar->TWO, '...', 'accessor works for reading' ); +$bar->TWO('!!!'); +is( $bar->TWO, '!!!', 'accessor works for writing' ); + +{ + package Baz; + use Moo; + + ::is(::exception { + has '@three' => ( + is => 'lazy', + default => sub { 3 }, + reader => 'three', + ); + }, undef, 'declaring non-identifier attribute with proper reader works'); +} + +is( Baz->new->three, 3, '... and reader works'); + +done_testing; diff --git a/t/accessor-roles.t b/t/accessor-roles.t new file mode 100644 index 0000000..51ffb31 --- /dev/null +++ b/t/accessor-roles.t @@ -0,0 +1,56 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; +use Sub::Quote; + +{ + package One; use Moo; + has one => (is => 'ro', default => sub { 'one' }); + + package One::P1; use Moo::Role; + has two => (is => 'ro', default => sub { 'two' }); + + package One::P2; use Moo::Role; + has three => (is => 'ro', default => sub { 'three' }); + has four => (is => 'ro', lazy => 1, default => sub { 'four' }, predicate => 1); + + package One::P3; use Moo::Role; + has '+three' => (is => 'ro', default => sub { 'three' }); +} + +my $combined = Moo::Role->create_class_with_roles('One', qw(One::P1 One::P2)); +isa_ok $combined, "One"; +ok $combined->does($_), "Does $_" for qw(One::P1 One::P2); +ok !$combined->does('One::P3'), 'Does not One::P3'; + +my $c = $combined->new; +is $c->one, "one", "attr default set from class"; +is $c->two, "two", "attr default set from role"; +is $c->three, "three", "attr default set from role"; + +{ + package Deux; use Moo; with 'One::P1'; + ::like( + ::exception { has two => (is => 'ro', default => sub { 'II' }); }, + qr{^You cannot overwrite a locally defined method \(two\) with a reader}, + 'overwriting accesssors with roles fails' + ); +} + +{ + package Two; use Moo; with 'One::P1'; + has '+two' => (is => 'ro', default => sub { 'II' }); +} + +is(Two->new->two, 'II', "overwriting accessors using +attr works"); + +my $o = One->new; +Moo::Role->apply_roles_to_object($o, 'One::P2'); +is($o->three, 'three', 'attr default set from role applied to object'); +ok(!$o->has_four, 'lazy attr default not set on apply'); + +$o = $combined->new(three => '3'); +Moo::Role->apply_roles_to_object($o, 'One::P3'); +is($o->three, '3', 'attr default not used when already set when role applied to object'); + +done_testing; diff --git a/t/accessor-shortcuts.t b/t/accessor-shortcuts.t new file mode 100644 index 0000000..b54c75b --- /dev/null +++ b/t/accessor-shortcuts.t @@ -0,0 +1,43 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +my $test = "test"; +my $lazy_default = "lazy_default"; + +{ + package Foo; + + use Moo; + + has rwp => (is => 'rwp'); + has lazy => (is => 'lazy'); + sub _build_lazy { $test } + has lazy_default => (is => 'lazy', default => sub { $lazy_default }); +} + +my $foo = Foo->new; + +# rwp +{ + is $foo->rwp, undef, "rwp value starts out undefined"; + ok exception { $foo->rwp($test) }, "rwp is read_only"; + is exception { $foo->_set_rwp($test) }, undef, "rwp can be set by writer"; + is $foo->rwp, $test, "rwp value was set by writer"; +} + +# lazy +{ + is $foo->{lazy}, undef, "lazy value storage is undefined"; + is $foo->lazy, $test, "lazy value returns test value when called"; + ok exception { $foo->lazy($test) }, "lazy is read_only"; +} + +# lazy + default +{ + is $foo->{lazy_default}, undef, "lazy_default value storage is undefined"; + is $foo->lazy_default, $lazy_default, "lazy_default value returns test value when called"; + ok exception { $foo->lazy_default($test) }, "lazy_default is read_only"; +} + +done_testing; diff --git a/t/accessor-trigger.t b/t/accessor-trigger.t new file mode 100644 index 0000000..4465659 --- /dev/null +++ b/t/accessor-trigger.t @@ -0,0 +1,149 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +our @tr; + +sub run_for { + my $class = shift; + + @tr = (); + + my $obj = $class->new; + + ok(!@tr, "${class}: trigger not fired with no value"); + + $obj = $class->new(one => 1); + + is_deeply(\@tr, [ 1 ], "${class}: trigger fired on new"); + + my $res = $obj->one(2); + + is_deeply(\@tr, [ 1, 2 ], "${class}: trigger fired on set"); + + is($res, 2, "${class}: return from set ok"); + + is($obj->one, 2, "${class}: return from accessor ok"); + + is_deeply(\@tr, [ 1, 2 ], "${class}: trigger not fired for accessor as get"); +} + +{ + package Foo; + + use Moo; + + has one => (is => 'rw', trigger => sub { push @::tr, $_[1] }); +} + +run_for 'Foo'; + +{ + package Bar; + + use Sub::Quote; + use Moo; + + has one => (is => 'rw', trigger => quote_sub q{ push @::tr, $_[1] }); +} + +run_for 'Bar'; + +{ + package Baz; + + use Sub::Quote; + use Moo; + + has one => ( + is => 'rw', + trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr }) + ); +} + +run_for 'Baz'; + +{ + package Default; + + use Sub::Quote; + use Moo; + + has one => ( + is => 'rw', + trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr }), + default => sub { 0 } + ); +} + +run_for 'Default'; + +{ + package LazyDefault; + + use Sub::Quote; + use Moo; + + has one => ( + is => 'rw', + trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr }), + default => sub { 0 }, + lazy => 1 + ); +} + +run_for 'LazyDefault'; + +{ + package Shaz; + + use Moo; + + has one => (is => 'rw', trigger => 1 ); + + sub _trigger_one { push @::tr, $_[1] } +} + +run_for 'Shaz'; + +{ + package AccessorValue; + + use Moo; + + has one => ( + is => 'rw', + isa => sub { 1 }, + trigger => sub { push @::tr, $_[0]->one }, + ); +} + +run_for 'AccessorValue'; + +{ + package TriggerWriter; + use Moo; + has attr => ( + is => 'rwp', + trigger => sub { die 'triggered' }, + ); +} +like exception { TriggerWriter->new->_set_attr( 4 ) }, + qr/triggered/, "trigger triggered via writer"; + +is exception { + package TriggerNoInit; + use Moo; + has attr => ( + is => 'rw', + default => 1, + init_arg => undef, + trigger => sub { die 'triggered' }, + ); +}, undef, + 'trigger+default+init_arg undef works'; + +is exception { TriggerNoInit->new }, undef, + 'trigger not called on default without init_arg'; + +done_testing; diff --git a/t/accessor-weaken-pre-5_8_3.t b/t/accessor-weaken-pre-5_8_3.t new file mode 100644 index 0000000..5cbca6e --- /dev/null +++ b/t/accessor-weaken-pre-5_8_3.t @@ -0,0 +1,12 @@ +use Moo::_strictures; +use File::Spec; +BEGIN { + $ENV{MOO_TEST_PRE_583} = 1; +} + +(my $real_test = File::Spec->rel2abs(__FILE__)) =~ s/-pre-5_8_3//; + +unless (defined do $real_test) { + die "$real_test: $@" if $@; + die "$real_test: $!" if $!; +} diff --git a/t/accessor-weaken.t b/t/accessor-weaken.t new file mode 100644 index 0000000..30179f0 --- /dev/null +++ b/t/accessor-weaken.t @@ -0,0 +1,77 @@ +use Moo::_strictures; +use Test::More; +use Moo::_Utils (); + +note "pretending to be pre-5.8.3" + if $ENV{MOO_TEST_PRE_583}; + +{ + package Foo; + + use Moo; + + has one => (is => 'rw', weak_ref => 1); + has four=> (is => 'rw', weak_ref => 1, writer => 'set_four'); + + package Foo2; + + use Moo; + + our $preexist = {}; + has one => (is => 'rw', lazy => 1, weak_ref => 1, default => sub { $preexist }); + has two => (is => 'rw', lazy => 1, weak_ref => 1, default => sub { {} }); +} + +my $ref = {}; +my $foo = Foo->new(one => $ref); +is($foo->one, $ref, 'value present'); +ok(Scalar::Util::isweak($foo->{one}), 'value weakened'); +undef $ref; +ok(!defined $foo->{one}, 'weak value gone'); + +my $foo2 = Foo2->new; +ok(my $ref2 = $foo2->one, 'external value returned'); +is($foo2->one, $ref2, 'value maintained'); +ok(Scalar::Util::isweak($foo2->{one}), 'value weakened'); +is($foo2->one($ref2), $ref2, 'value returned from setter'); +undef $ref2; +ok(!defined $foo->{one}, 'weak value gone'); + +is($foo2->two, undef, 'weak+lazy ref not returned'); +is($foo2->{two}, undef, 'internal value not set'); +my $ref3 = {}; +is($foo2->two($ref3), $ref3, 'value returned from setter'); +undef $ref3; +ok(!defined $foo->{two}, 'weak value gone'); + +my $ref4 = {}; +my $foo4 = Foo->new; +$foo4->set_four($ref4); +is($foo4->four, $ref4, 'value present'); +ok(Scalar::Util::isweak($foo4->{four}), 'value weakened'); +undef $ref4; +ok(!defined $foo4->{four}, 'weak value gone'); + + +# test readonly SVs +sub mk_ref { \ 'yay' }; +my $foo_ro = eval { Foo->new(one => mk_ref()) }; +if ("$]" < 5.008_003) { + like( + $@, + qr/\QReference to readonly value in "one" can not be weakened on Perl < 5.8.3/, + 'Expected exception thrown on old perls' + ); +} +elsif ($^O eq 'cygwin' and "$]" < 5.012_000) { + SKIP: { skip 'Static coderef reaping seems nonfunctional on cygwin < 5.12', 1 } +} +else { + is(${$foo_ro->one},'yay', 'value present'); + ok(Scalar::Util::isweak($foo_ro->{one}), 'value weakened'); + + { no warnings 'redefine'; *mk_ref = sub {} } + ok (!defined $foo_ro->{one}, 'optree reaped, ro static value gone'); +} + +done_testing; diff --git a/t/buildall-subconstructor.t b/t/buildall-subconstructor.t new file mode 100644 index 0000000..efc2c82 --- /dev/null +++ b/t/buildall-subconstructor.t @@ -0,0 +1,88 @@ +use Moo::_strictures; +use Test::More; + +my @ran; + +{ + package Foo; use Moo; sub BUILD { push @ran, 'Foo' } + package Bar; use Moo; extends 'Foo'; sub BUILD { push @ran, 'Bar' } + package Baz; use Moo; extends 'Bar'; + package Quux; use Moo; extends 'Baz'; sub BUILD { push @ran, 'Quux' } +} + +{ + package Fleem; + use Moo; + extends 'Quux'; + has 'foo' => (is => 'ro'); + sub BUILD { push @ran, $_[0]->foo, $_[1]->{bar} } +} + +{ + package Odd1; + use Moo; + has 'odd1' => (is => 'ro'); + sub BUILD { push @ran, 'Odd1' } + package Odd2; + use Moo; + extends 'Odd1'; + package Odd3; + use Moo; + extends 'Odd2'; + has 'odd3' => (is => 'ro'); + sub BUILD { push @ran, 'Odd3' } +} + +{ + package Sub1; + use Moo; + has 'foo' => (is => 'ro'); + package Sub2; + use Moo; + extends 'Sub1'; + sub BUILD { push @ran, "sub2" } +} + +my @tests = ( + 'Foo' => { + ran => [qw( Foo )], + }, + 'Bar' => { + ran => [qw( Foo Bar )], + }, + 'Baz' => { + ran => [qw( Foo Bar )], + }, + 'Quux' => { + ran => [qw( Foo Bar Quux )], + }, + 'Fleem' => { + ran => [qw( Foo Bar Quux Fleem1 Fleem2 )], + args => [ foo => 'Fleem1', bar => 'Fleem2' ], + }, + 'Odd1' => { + ran => [qw( Odd1 )], + }, + 'Odd2' => { + ran => [qw( Odd1 )], + }, + 'Odd3' => { + ran => [qw( Odd1 Odd3 )], + args => [ odd1 => 1, odd3 => 3 ], + }, + 'Sub1' => { + ran => [], + }, + 'Sub2' => { + ran => [qw( sub2 )], + }, +); + +while ( my ($class, $conf) = splice(@tests,0,2) ) { + my $o = $class->new( @{ $conf->{args} || [] } ); + isa_ok($o, $class); + is_deeply(\@ran, $conf->{ran}, 'BUILDs ran in order'); + @ran = (); +} + +done_testing; diff --git a/t/buildall.t b/t/buildall.t new file mode 100644 index 0000000..bb010e8 --- /dev/null +++ b/t/buildall.t @@ -0,0 +1,94 @@ +use Moo::_strictures; +use Test::More; + +my @ran; + +{ + package Foo; use Moo; sub BUILD { push @ran, 'Foo' } + package Bar; use Moo; extends 'Foo'; sub BUILD { push @ran, 'Bar' } + package Baz; use Moo; extends 'Bar'; + package Quux; use Moo; extends 'Baz'; sub BUILD { push @ran, 'Quux' } +} + +{ + package Fleem; + use Moo; + extends 'Quux'; + has 'foo' => (is => 'ro'); + sub BUILD { push @ran, $_[0]->foo, $_[1]->{bar} } +} + +{ + package Odd1; + use Moo; + has 'odd1' => (is => 'ro'); + sub BUILD { push @ran, 'Odd1' } + package Odd2; + use Moo; + extends 'Odd1'; + package Odd3; + use Moo; + extends 'Odd2'; + has 'odd3' => (is => 'ro'); + sub BUILD { push @ran, 'Odd3' } +} + +{ + package Sub1; + use Moo; + has 'foo' => (is => 'ro'); + package Sub2; + use Moo; + extends 'Sub1'; + sub BUILD { push @ran, "sub2" } +} + +my $o = Quux->new; + +is(ref($o), 'Quux', 'object returned'); +is_deeply(\@ran, [ qw(Foo Bar Quux) ], 'BUILDs ran in order'); + +@ran = (); + +$o = Fleem->new(foo => 'Fleem1', bar => 'Fleem2'); + +is(ref($o), 'Fleem', 'object with inline constructor returned'); +is_deeply(\@ran, [ qw(Foo Bar Quux Fleem1 Fleem2) ], 'BUILDs ran in order'); + +@ran = (); + +$o = Odd3->new(odd1 => 1, odd3 => 3); + +is(ref($o), 'Odd3', 'Odd3 object constructed'); +is_deeply(\@ran, [ qw(Odd1 Odd3) ], 'BUILDs ran in order'); + +@ran = (); + +$o = Sub2->new; + +is(ref($o), 'Sub2', 'Sub2 object constructed'); +is_deeply(\@ran, [ qw(sub2) ], 'BUILD ran'); + +@ran = (); + +$o = Sub2->new(__no_BUILD__ => 1); + +is_deeply(\@ran, [], '__no_BUILD__ surpresses BUILD running'); + +{ + package WithCoerce; + use Moo; + + has attr1 => ( is => 'ro', coerce => sub { $_[0] + 5 } ); + has build_params => ( is => 'rw', init_arg => undef ); + + sub BUILD { + my ($self, $args) = @_; + $self->build_params($args); + } +} + +$o = WithCoerce->new(attr1 => 2); +is +$o->build_params->{attr1}, 2, 'BUILD gets uncoerced arguments'; + +done_testing; diff --git a/t/buildargs-error.t b/t/buildargs-error.t new file mode 100644 index 0000000..3398780 --- /dev/null +++ b/t/buildargs-error.t @@ -0,0 +1,25 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moo; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ($self, $args) = @_; + + return %$args + } +} + +like( + exception { Foo->new({ bar => 1, baz => 1 }) }, + qr/BUILDARGS did not return a hashref/, + 'Sensible error message' +); + +done_testing; diff --git a/t/buildargs.t b/t/buildargs.t new file mode 100644 index 0000000..198b94e --- /dev/null +++ b/t/buildargs.t @@ -0,0 +1,154 @@ +use Moo::_strictures; +use Test::More; + +{ + package Qux; + use Moo; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + package Quux; + use Moo; + + extends qw(Qux); +} + +{ + package NonMooClass; + + sub new { + my ($class, $arg) = @_; + bless { attr => $arg }, $class; + } + + sub attr { shift->{attr} } + + package Extends::NonMooClass::WithAttr; + use Moo; + extends qw( NonMooClass ); + + has 'attr2' => ( is => 'ro' ); + + sub BUILDARGS { + my ( $class, @args ) = @_; + shift @args if @args % 2 == 1; + return { @args }; + } +} + + +{ + package Foo; + use Moo; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $class, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return $class->SUPER::BUILDARGS(@args); + } + + package Bar; + use Moo; + + extends qw(Foo); +} + +{ + package Baz; + use Moo; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + around BUILDARGS => sub { + my $orig = shift; + my ( $class, @args ) = @_; + + unshift @args, "bar" if @args % 2 == 1; + + return $class->$orig(@args); + }; + + package Biff; + use Moo; + + extends qw(Baz); +} + +foreach my $class (qw(Foo Bar Baz Biff)) { + 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 baz'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right baz'); + } +} + +foreach my $class (qw(Qux Quux)) { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right baz'); + + eval { + $class->new( 37 ); + }; + like( $@, qr/Single parameters to new\(\) must be a HASH ref/, + "new() requires a list or a HASH ref" + ); + + eval { + $class->new( [ 37 ] ); + }; + like( $@, qr/Single parameters to new\(\) must be a HASH ref/, + "new() requires a list or a HASH ref" + ); + + eval { + $class->new( bar => 42, baz => 47, 'quux' ); + }; + like( $@, qr/You passed an odd number of arguments/, + "new() requires a list or a HASH ref" + ); +} + +my $non_moo = NonMooClass->new( 'bar' ); +my $ext_non_moo = Extends::NonMooClass::WithAttr->new( 'bar', attr2 => 'baz' ); + +is $non_moo->attr, 'bar', + "non-moo accepts params"; +is $ext_non_moo->attr, 'bar', + "extended non-moo passes params"; +is $ext_non_moo->attr2, 'baz', + "extended non-moo has own attributes"; + +{ + package NoAttr; + use Moo; + before BUILDARGS => sub { + our $buildargs_called++; + }; +} + +eval { + NoAttr->BUILDARGS( 37 ); +}; +like( $@, qr/Single parameters to new\(\) must be a HASH ref/, + "default BUILDARGS requires a list or a HASH ref" +); +$NoAttr::buildargs_called = 0; +my $noattr = NoAttr->new({ foo => 'bar' }); +is $noattr->{foo}, undef, 'without attributes, no params are stored'; +is $NoAttr::buildargs_called, 1, 'BUILDARGS called even without attributes'; + +done_testing; diff --git a/t/coerce-1.t b/t/coerce-1.t new file mode 100644 index 0000000..f419756 --- /dev/null +++ b/t/coerce-1.t @@ -0,0 +1,92 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package IntConstraint; + use Moo; + use overload '&{}' => sub { shift->constraint }, fallback => 1; + has constraint => ( + is => 'ro', + default => sub { + sub { $_[0] eq int $_[0] or die } + }, + ); + sub check { + my $self = shift; + !!eval { $self->constraint->(@_); 1 } + } +} + +# First supported interface for coerce=>1. +# The type constraint provides an $isa->coerce($value) method. +{ + package IntConstraint::WithCoerceMethod; + use Moo; + extends qw(IntConstraint); + sub coerce { + my $self = shift; + int($_[0]); + } +} + +# First supported interface for coerce=>1. +# The type constraint provides an $isa->coercion method +# providing a coderef such that $coderef->($value) coerces. +{ + package IntConstraint::WithCoercionMethod; + use Moo; + extends qw(IntConstraint); + has coercion => ( + is => 'ro', + default => sub { + sub { int($_[0]) } + }, + ); +} + +{ + package Goo; + use Moo; + + ::like(::exception { + has foo => ( + is => 'ro', + isa => sub { $_[0] eq int $_[0] }, + coerce => 1, + ); + }, qr/Invalid coercion/, + 'coerce => 1 not allowed when isa has no coercion'); + + ::like(::exception { + has foo => ( + is => 'ro', + isa => IntConstraint->new, + coerce => 1, + ); + }, qr/Invalid coercion/, + 'coerce => 1 not allowed when isa has no coercion'); + + has bar => ( + is => 'ro', + isa => IntConstraint::WithCoercionMethod->new, + coerce => 1, + ); + + has baz => ( + is => 'ro', + isa => IntConstraint::WithCoerceMethod->new, + coerce => 1, + ); + +} + +my $obj = Goo->new( + bar => 3.14159, + baz => 3.14159, +); + +is($obj->bar, '3', '$isa->coercion'); +is($obj->baz, '3', '$isa->coerce'); + +done_testing; diff --git a/t/compose-conflicts.t b/t/compose-conflicts.t new file mode 100644 index 0000000..6516b40 --- /dev/null +++ b/t/compose-conflicts.t @@ -0,0 +1,179 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package MethodRole; + use Moo::Role; + sub method { __PACKAGE__ } +} + +BEGIN { + package MethodRole2; + use Moo::Role; + sub method { __PACKAGE__ } +} + +BEGIN { + package MethodClassOver; + use Moo; + sub method { __PACKAGE__ } + with 'MethodRole'; +} + +BEGIN { + is +MethodClassOver->new->method, 'MethodClassOver', + 'class methods override role methods'; +} + +BEGIN { + package MethodRole2; + use Moo::Role; + has attr => (is => 'rw', coerce => sub { __PACKAGE__ } ); +} + +BEGIN { + package MethodClassAndRoleAndRole; + use Moo; + with 'MethodRole'; + with 'MethodRole2'; +} + +BEGIN { + my $o = + is +MethodClassAndRoleAndRole->new->method, 'MethodRole', + 'composed methods override later composed methods'; +} + +BEGIN { + package MethodClassAndRoles; + use Moo; + ::like ::exception { + with 'MethodRole', 'MethodRole2'; + }, qr/^Due to a method name conflict between roles/, + 'composing roles with conflicting methods fails'; +} + +BEGIN { + package MethodRoleOver; + use Moo::Role; + sub method { __PACKAGE__ } + with 'MethodRole'; +} + +BEGIN { + package MethodClassAndRoleOver; + use Moo; + with 'MethodRoleOver'; +} + +BEGIN { + is +MethodClassAndRoleOver->new->method, 'MethodRoleOver', + 'composing role methods override composed role methods'; +} + +BEGIN { + package MethodClassOverAndRoleOver; + use Moo; + sub method { __PACKAGE__ } + with 'MethodRoleOver'; +} + +BEGIN { + is +MethodClassOverAndRoleOver->new->method, 'MethodClassOverAndRoleOver', + 'class methods override role and role composed methods'; +} + + +BEGIN { + package AttrRole; + use Moo::Role; + has attr => (is => 'rw', coerce => sub { __PACKAGE__ } ); +} + +BEGIN { + package AttrClassOver; + use Moo; + has attr => (is => 'rw', coerce => sub { __PACKAGE__ }); + with 'AttrRole'; +} + +BEGIN { + my $o = AttrClassOver->new(attr => 1); + is $o->attr, 'AttrClassOver', + 'class attributes override role attributes in constructor'; + $o->attr(1); + is $o->attr, 'AttrClassOver', + 'class attributes override role attributes in accessors'; +} + +BEGIN { + package AttrRole2; + use Moo::Role; + has attr => (is => 'rw', coerce => sub { __PACKAGE__ } ); +} + +BEGIN { + package AttrClassAndRoleAndRole; + use Moo; + with 'AttrRole'; + with 'AttrRole2'; +} + +BEGIN { + my $o = AttrClassAndRoleAndRole->new(attr => 1); + is $o->attr, 'AttrRole', + 'composed attributes override later composed attributes in constructor'; + $o->attr(1); + is $o->attr, 'AttrRole', + 'composed attributes override later composed attributes in accessors'; +} + +BEGIN { + package AttrClassAndRoles; + use Moo; + ::like ::exception { + with 'AttrRole', 'AttrRole2'; + }, qr/^Due to a method name conflict between roles/, + 'composing roles with conflicting attributes fails'; +} + +BEGIN { + package AttrRoleOver; + use Moo::Role; + has attr => (is => 'rw', coerce => sub { __PACKAGE__ }); + with 'AttrRole'; +} + +BEGIN { + package AttrClassAndRoleOver; + use Moo; + with 'AttrRoleOver'; +} + +BEGIN { + my $o = AttrClassAndRoleOver->new(attr => 1); + is $o->attr, 'AttrRoleOver', + 'composing role attributes override composed role attributes in constructor'; + $o->attr(1); + is $o->attr, 'AttrRoleOver', + 'composing role attributes override composed role attributes in accessors'; +} + +BEGIN { + package AttrClassOverAndRoleOver; + use Moo; + has attr => (is => 'rw', coerce => sub { __PACKAGE__ }); + with 'AttrRoleOver'; +} + +BEGIN { + my $o = AttrClassOverAndRoleOver->new(attr => 1); + is $o->attr, 'AttrClassOverAndRoleOver', + 'class attributes override role and role composed attributes in constructor'; + $o->attr(1); + is $o->attr, 'AttrClassOverAndRoleOver', + 'class attributes override role and role composed attributes in accessors'; +} + +done_testing; diff --git a/t/compose-non-role.t b/t/compose-non-role.t new file mode 100644 index 0000000..d0a38b3 --- /dev/null +++ b/t/compose-non-role.t @@ -0,0 +1,14 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +$INC{'MyRole.pm'} = __FILE__; + +{ + package MyClass; + use Moo; + ::like(::exception { with 'MyRole'; }, qr/MyRole is not a Moo::Role/, + 'error when composing non-role package'); +} + +done_testing; diff --git a/t/compose-roles.t b/t/compose-roles.t new file mode 100644 index 0000000..fedf77d --- /dev/null +++ b/t/compose-roles.t @@ -0,0 +1,173 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package One; use Moo::Role; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package Two; use Moo::Role; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package Three; use Moo::Role; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package Four; use Moo::Role; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package BaseClass; sub foo { __PACKAGE__ } +} + +foreach my $combo ( + [ qw(One Two Three Four) ], + [ qw(Two Four Three) ], + [ qw(One Two) ] +) { + my $combined = Moo::Role->create_class_with_roles('BaseClass', @$combo); + is_deeply( + [ $combined->foo ], [ reverse(@$combo), 'BaseClass' ], + "${combined} ok" + ); + my $object = bless({}, 'BaseClass'); + Moo::Role->apply_roles_to_object($object, @$combo); + is(ref($object), $combined, 'Object reblessed into correct class'); +} + +{ + package RoleWithAttr; + use Moo::Role; + + has attr1 => (is => 'ro', default => -1); + + package RoleWithAttr2; + use Moo::Role; + + has attr2 => (is => 'ro', default => -2); + + package ClassWithAttr; + use Moo; + + has attr3 => (is => 'ro', default => -3); +} + +Moo::Role->apply_roles_to_package('ClassWithAttr', 'RoleWithAttr', 'RoleWithAttr2'); +my $o = ClassWithAttr->new(attr1 => 1, attr2 => 2, attr3 => 3); +is($o->attr1, 1, 'attribute from role works'); +is($o->attr2, 2, 'attribute from role 2 works'); +is($o->attr3, 3, 'attribute from base class works'); + +{ + package SubClassWithoutAttr; + use Moo; + extends 'ClassWithAttr'; +} + +my $o2 = Moo::Role->create_class_with_roles( + 'SubClassWithoutAttr', 'RoleWithAttr')->new; +is($o2->attr3, -3, 'constructor includes base class'); +is($o2->attr2, -2, 'constructor includes role'); + +{ + package AccessorExtension; + use Moo::Role; + around 'generate_method' => sub { + my $orig = shift; + my $me = shift; + my ($into, $name) = @_; + $me->$orig(@_); + no strict 'refs'; + *{"${into}::_${name}_marker"} = sub { }; + }; +} + +{ + package RoleWithReq; + use Moo::Role; + requires '_attr1_marker'; +} + +is exception { + package ClassWithExtension; + use Moo; + Moo::Role->apply_roles_to_object( + Moo->_accessor_maker_for(__PACKAGE__), + 'AccessorExtension'); + + with qw(RoleWithAttr RoleWithReq); +}, undef, 'apply_roles_to_object correctly calls accessor generator'; + +{ + package EmptyClass; + use Moo; +} + +{ + package RoleWithReq2; + use Moo::Role; + requires 'attr2'; +} + +is exception { + Moo::Role->create_class_with_roles( + 'EmptyClass', 'RoleWithReq2', 'RoleWithAttr2'); +}, undef, 'create_class_with_roles accepts attributes for requirements'; + +like exception { + Moo::Role->create_class_with_roles( + 'EmptyClass', 'RoleWithReq2', 'RoleWithAttr'); +}, qr/Can't apply .* missing attr2/, + 'create_class_with_roles accepts attributes for requirements'; + +{ + package RoleWith2Attrs; + use Moo::Role; + + has attr1 => (is => 'ro', default => -1); + has attr2 => (is => 'ro', default => -2); +} + +foreach my $combo ( + [qw(RoleWithAttr RoleWithAttr2)], + [qw(RoleWith2Attrs)], +) { + is exception { + my $o = Moo::Role->apply_roles_to_object( + EmptyClass->new, @$combo); + is($o->attr1, -1, 'first attribute works'); + is($o->attr2, -2, 'second attribute works'); + }, undef, "apply_roles_to_object with multiple attrs with defaults (@$combo)"; +} + +{ + package Some::Class; + use Moo; + sub foo { 1 } +} + +like exception { + Moo::Role->apply_roles_to_package('EmptyClass', 'Some::Class'); +}, qr/Some::Class is not a Moo::Role/, + 'apply_roles_to_package throws error on non-role'; + +like exception { + Moo::Role->apply_single_role_to_package('EmptyClass', 'Some::Class'); +}, qr/Some::Class is not a Moo::Role/, + 'apply_single_role_to_package throws error on non-role'; + +like exception { + Moo::Role->create_class_with_roles('EmptyClass', 'Some::Class'); +}, qr/Some::Class is not a Moo::Role/, + 'can only create class with roles'; + +delete Moo->_constructor_maker_for('Some::Class')->{attribute_specs}; +is exception { + Moo::Role->apply_roles_to_package('Some::Class', 'RoleWithAttr'); +}, undef, + 'apply_roles_to_package copes with missing attribute specs'; + +{ + package Non::Moo::Class; + sub new { bless {}, $_[0] } +} + +Moo::Role->apply_roles_to_package('Non::Moo::Class', 'RoleWithAttr'); +ok +Non::Moo::Class->can('attr1'), + 'can apply role with attributes to non Moo class'; + +done_testing; diff --git a/t/constructor-modify.t b/t/constructor-modify.t new file mode 100644 index 0000000..56a5ec6 --- /dev/null +++ b/t/constructor-modify.t @@ -0,0 +1,139 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package ClassBakedNew; + use Moo; + + has attr1 => (is => 'ro'); + __PACKAGE__->new; + + ::like ::exception { + has attr2 => (is => 'ro'); + }, qr/Constructor for ClassBakedNew has been inlined/, + 'error when adding attributes with undeferred constructor'; +} + +BEGIN { + package ClassExistingNew; + use Moo; + no warnings 'once'; + + sub new { + our $CALLED++; + bless {}, $_[0]; + } + + ::like ::exception { + has attr1 => (is => 'ro'); + }, qr/Unknown constructor for ClassExistingNew already exists/, + 'error when adding attributes with foreign constructor'; +} + +BEGIN { + package ClassDeferredNew; + use Moo; + no warnings 'once'; + use Sub::Quote; + + quote_sub __PACKAGE__ . '::new' => q{ + our $CALLED++; + bless {}, $_[0]; + }; + + ::like ::exception { + has attr1 => (is => 'ro'); + }, qr/Unknown constructor for ClassDeferredNew already exists/, + 'error when adding attributes with foreign deferred constructor'; +} + +BEGIN { + package ClassWithModifier; + use Moo; + no warnings 'once'; + + has attr1 => (is => 'ro'); + + around new => sub { + our $CALLED++; + my $orig = shift; + goto $orig; + }; + + ::like ::exception { + has attr2 => (is => 'ro'); + }, qr/Constructor for ClassWithModifier has been replaced with an unknown sub/, + 'error when adding attributes after applying modifier to constructor'; +} + +BEGIN { + package Role1; + use Moo::Role; + + has attr1 => (is => 'ro'); +} + +BEGIN { + package ClassWithRoleAttr; + use Moo; + no warnings 'once'; + + around new => sub { + our $CALLED++; + my $orig = shift; + goto $orig; + }; + + + ::like ::exception { + with 'Role1'; + }, qr/Unknown constructor for ClassWithRoleAttr already exists/, + 'error when adding role with attribute after applying modifier to constructor'; +} + + +BEGIN { + package RoleModifyNew; + use Moo::Role; + no warnings 'once'; + + around new => sub { + our $CALLED++; + my $orig = shift; + goto $orig; + }; +} + +BEGIN { + package ClassWithModifyRole; + use Moo; + no warnings 'once'; + with 'RoleModifyNew'; + + ::like ::exception { + has attr1 => (is => 'ro'); + }, qr/Unknown constructor for ClassWithModifyRole already exists/, + 'error when adding attributes after applying modifier to constructor via role'; +} + +BEGIN { + package AClass; + use Moo; + has attr1 => (is => 'ro'); +} + +BEGIN { + package ClassWithParent; + use Moo; + + has attr2 => (is => 'ro'); + __PACKAGE__->new; + + ::like ::exception { + extends 'AClass'; + }, qr/Constructor for ClassWithParent has been inlined/, + 'error when changing parent with undeferred constructor'; +} + +done_testing; diff --git a/t/croak-locations.t b/t/croak-locations.t new file mode 100644 index 0000000..3370a2a --- /dev/null +++ b/t/croak-locations.t @@ -0,0 +1,271 @@ +use Moo::_strictures; +use Test::More; +use Carp qw(croak); +no Moo::sification; +use lib 't/lib'; +use ErrorLocation; + +location_ok <<'END_CODE', 'Moo::_Util::_load_module'; +use Moo::_Utils qw(_load_module); +_load_module("This::Module::Does::Not::Exist::". int rand 50000); +END_CODE + +location_ok <<'END_CODE', 'Moo - import into role'; +use Moo::Role; +use Moo (); +Moo->import; +END_CODE + +location_ok <<'END_CODE', 'Moo::has - unbalanced options'; +use Moo; +has arf => (is => 'ro', 'garf'); +END_CODE + +location_ok <<'END_CODE', 'Moo::extends - extending a role'; +BEGIN { + eval qq{ + package ${PACKAGE}::Role; + use Moo::Role; + 1; + } or die $@; +} + +use Moo; +extends "${PACKAGE}::Role"; +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Accessor - missing is'; +use Moo; +has 'attr'; +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Accessor - reader extra params'; +use Moo; +has 'attr' => (is => 'rwp', lazy => 1, default => 1); +my $o = $PACKAGE->new; +package Elsewhere; +$o->attr(5); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Accessor - overwrite method'; +use Moo; +sub attr { 1 } +has 'attr' => (is => 'ro'); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Accessor - asserter with unset'; +use Moo; +has 'attr' => (is => 'ro', asserter => 'assert_attr'); +my $o = $PACKAGE->new; +package Elsewhere; +$o->assert_attr; +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Accessor - invalid default'; +use Moo; +sub attr { 1 } +has 'attr' => (is => 'ro', default => []); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - +attr without attr'; +use Moo; +has 'attr' => (is => 'ro'); +has 'attr' => (default => 1); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - modifying @ISA unexpectedly'; +BEGIN { + eval qq{ + package ${PACKAGE}::Parent$_; + use Moo; + has attr$_ => (is => 'ro'); + __PACKAGE__->new; + 1; + } or die $@ + for (1, 2); +} + +use Moo; +extends "${PACKAGE}::Parent1"; +has attr3 => (is => 'ro'); +our @ISA = "${PACKAGE}::Parent2"; +package Elsewhere; +$PACKAGE->new; +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - existing constructor'; +use Moo; +sub new { } +has attr => (is => 'ro'); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - BUILDARGS output'; +use Moo; +sub BUILDARGS { 1 } +has attr => (is => 'ro'); +package Elsewhere; +$PACKAGE->new; +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - inlined BUILDARGS output'; +use Moo; +has attr => (is => 'ro'); +package Elsewhere; +$PACKAGE->new(5); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - inlined BUILDARGS output (wrapped)'; +use Moo; +has attr => (is => 'ro'); +sub wrap_new { + my $class = shift; + $class->new(@_); +} +package Elsewhere; +$PACKAGE->wrap_new(5); +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Constructor - required attributes'; +use Moo; +has attr => (is => 'ro', required => 1); +package Elsewhere; +$PACKAGE->new; +END_CODE + +location_ok <<'END_CODE', 'Moo::HandleMoose::FakeMetaClass - class method call'; +require Moo::HandleMoose::FakeMetaClass; +Moo::HandleMoose::FakeMetaClass->guff; +END_CODE + +location_ok <<'END_CODE', 'Moo::Object - new args'; +use Moo::Object; +our @ISA = 'Moo::Object'; +package Elsewhere; +$PACKAGE->new(5); +END_CODE + +location_ok <<'END_CODE', 'Moo::Role - import into class'; +use Moo; +use Moo::Role (); +Moo::Role->import; +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::has - unbalanced options'; +use Moo::Role; +has arf => (is => 'ro', 'garf'); +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::methods_provided_by - not a role'; +BEGIN { + eval qq{ + package ${PACKAGE}::Class; + use Moo; + 1; + } or die $@; +} + +use Moo; +has arf => (is => 'ro', handles => "${PACKAGE}::Class"); +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::apply_roles_to_package - not a module'; +use Moo; +with {}; +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::apply_roles_to_package - not a role'; +BEGIN { + eval qq{ + package ${PACKAGE}::Class; + use Moo; + 1; + } or die $@; +} + +use Moo; +with "${PACKAGE}::Class"; +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::apply_single_role_to_package - not a role'; +BEGIN { + eval qq{ + package ${PACKAGE}::Class; + use Moo; + 1; + } or die $@; +} + +use Moo; +use Moo::Role (); +Moo::Role->apply_single_role_to_package($PACKAGE, "${PACKAGE}::Class"); +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::create_class_with_roles - not a role'; +BEGIN { + eval qq{ + package ${PACKAGE}::Class; + use Moo; + 1; + } or die $@; +} + +use Moo; +use Moo::Role (); +Moo::Role->create_class_with_roles($PACKAGE, "${PACKAGE}::Class"); +END_CODE + +location_ok <<'END_CODE', 'Moo::HandleMoose::inject_all - Moo::sification disabled'; +use Moo::HandleMoose (); +Moo::HandleMoose->import; +END_CODE + +location_ok <<'END_CODE', 'Method::Generate::Accessor::_generate_delegation - user croak'; +BEGIN { + eval qq{ + package ${PACKAGE}::Class; + use Moo; + use Carp qw(croak); + sub method { + croak "AAA"; + } + 1; + } or die $@; +} + +use Moo; +has b => ( + is => 'ro', + handles => [ 'method' ], + default => sub { "${PACKAGE}::Class"->new }, +); + +package Elsewhere; +my $o = $PACKAGE->new; +$o->method; +END_CODE + +location_ok <<'END_CODE', 'Moo::Role::create_class_with_roles - default fails isa'; +BEGIN { + eval qq{ + package ${PACKAGE}::Role; + use Moo::Role; + use Carp qw(croak); + has attr => ( + is => 'ro', + default => sub { 0 }, + isa => sub { + croak "must be true" unless \$_[0]; + }, + ); + 1; + } or die $@; +} + +use Moo; +my $o = $PACKAGE->new; +package Elsewhere; +use Moo::Role (); +Moo::Role->apply_roles_to_object($o, "${PACKAGE}::Role"); +END_CODE + +done_testing; diff --git a/t/demolish-basics.t b/t/demolish-basics.t new file mode 100644 index 0000000..31b3797 --- /dev/null +++ b/t/demolish-basics.t @@ -0,0 +1,51 @@ + +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +our @demolished; +package Foo; +use Moo; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub; +use Moo; +extends 'Foo'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub::Sub; +use Moo; +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/demolish-bugs-eats_exceptions.t b/t/demolish-bugs-eats_exceptions.t new file mode 100644 index 0000000..179f51e --- /dev/null +++ b/t/demolish-bugs-eats_exceptions.t @@ -0,0 +1,139 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + + +my $FilePath = sub { die "does not pass the type constraint" if $_[0] eq '/' }; + +{ + package Baz; + use Moo; + + has 'path' => ( + is => 'ro', + isa => $FilePath, + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + die $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 Moo::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + } +} + +{ + package Qee; + use Moo; + + has 'path' => ( + is => 'ro', + isa => $FilePath, + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + die $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 Moo::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + } +} + +{ + package Foo; + use Moo; + + has 'path' => ( + is => 'ro', + isa => $FilePath, + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + die $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/Missing required argument/, "... $pkg plain" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new(); }; + ::like( $@, qr/Missing required argument/, "... $pkg empty" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( notanattr => 1 ); }; + ::like( $@, qr/Missing required argument/, "... $pkg undef" ); + ::is( $obj, undef, "... the object is undef" ); + } + + { + local $@; + my $obj = eval { $pkg->new ( %param ); }; + ::like( $@, qr/Missing required argument/, "... $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 => __FILE__ ); }; + ::is( $@, '', "... $pkg no error" ); + ::isa_ok( $obj, $pkg ); + ::isa_ok( $obj, 'Moo::Object' ); + ::is( $obj->path, __FILE__, "... $pkg got the right value" ); + } +} + +done_testing; diff --git a/t/demolish-bugs-eats_mini.t b/t/demolish-bugs-eats_mini.t new file mode 100644 index 0000000..d0adc3c --- /dev/null +++ b/t/demolish-bugs-eats_mini.t @@ -0,0 +1,75 @@ + +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moo; + + 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 Moo::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + # ... Moo (kinda) eats exceptions in DESTROY/DEMOLISH"; + } +} + +{ + my $obj = eval { Foo->new; }; + like( $@, qr/Missing required arguments/, "... 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 Moo; + + 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' ); + +} + +done_testing; diff --git a/t/demolish-global_destruction.t b/t/demolish-global_destruction.t new file mode 100644 index 0000000..90c1efd --- /dev/null +++ b/t/demolish-global_destruction.t @@ -0,0 +1,28 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; +use File::Basename qw(dirname); + +BEGIN { + package Foo; + use Moo; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)'; + } +} + +{ + my $foo = Foo->new; +} + +delete $ENV{PERL5LIB}; +delete $ENV{PERL5OPT}; +my $out = system $^X, (map "-I$_", @INC), dirname(__FILE__).'/global-destruction-helper.pl', 219; +is $out >> 8, 219, + 'in_global_destruction state is passed to DEMOLISH properly (false)'; + +done_testing; diff --git a/t/demolish-throw.t b/t/demolish-throw.t new file mode 100644 index 0000000..8e443f7 --- /dev/null +++ b/t/demolish-throw.t @@ -0,0 +1,54 @@ +sub clean_die { + use warnings; + die @_; +} + +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moo; + sub DEMOLISH { + die "Error in DEMOLISH"; + } +} +my @warnings; +my @looped_exceptions; +my $o = Foo->new; + +{ + local $SIG{__WARN__} = sub { + push @warnings, $_[0]; + }; + + # make sure we don't loop infinitely + my $last_die; + local $SIG{__DIE__} = sub { + my $location = join(':', caller); + if ($last_die && $last_die eq $location) { + push @looped_exceptions, $_[0]; + clean_die(@_); + } + $last_die = $location; + }; + + { + no warnings FATAL => 'misc'; + use warnings 'misc'; + undef $o; + # if undef is the last statement in a block, its effect is delayed until + # after the block is cleaned up (and our warning settings won't be applied) + 1; + } +} + +like $warnings[0], qr/\(in cleanup\) Error in DEMOLISH/, + 'error in DEMOLISH converted to warning'; +is scalar @warnings, 1, + 'no other warnings generated'; +is scalar @looped_exceptions, 0, + 'no infinitely looping exception in DESTROY'; + +done_testing; diff --git a/t/does.t b/t/does.t new file mode 100644 index 0000000..b116a53 --- /dev/null +++ b/t/does.t @@ -0,0 +1,47 @@ +use Moo::_strictures; +use Test::More; + +BEGIN { + package TestParent; + use Moo; +} + +BEGIN { + package TestClass; + use Moo; + extends 'TestParent'; + + has attr1 => (is => 'ro'); +} + +BEGIN { + ok !TestClass->does('TestRole'), + "->does returns false for arbitrary role"; + ok !$INC{'Moo/Role.pm'}, + "Moo::Role not loaded by does"; +} + +BEGIN { + package TestRole; + use Moo::Role; + + has attr2 => (is => 'ro'); +} + +BEGIN { + package TestClass; + with 'TestRole'; +} + +BEGIN { + ok +TestClass->does('TestRole'), + "->does returns true for composed role"; + + ok +TestClass->DOES('TestRole'), + "->DOES returns true for composed role"; + + ok +TestClass->DOES('TestParent'), + "->DOES returns true for parent class"; +} + +done_testing; diff --git a/t/extend-constructor.t b/t/extend-constructor.t new file mode 100644 index 0000000..0b44f66 --- /dev/null +++ b/t/extend-constructor.t @@ -0,0 +1,29 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package Role::For::Constructor; + use Moo::Role; + has extra_param => (is => 'ro'); +} +BEGIN { + package Some::Class; + use Moo; + BEGIN { + my $con = Moo->_constructor_maker_for(__PACKAGE__); + Moo::Role->apply_roles_to_object($con, 'Role::For::Constructor'); + } +} + +{ + package Some::SubClass; + use Moo; + extends 'Some::Class'; + + ::is(::exception { + has bar => (is => 'ro'); + }, undef, 'extending constructor generator works'); +} + +done_testing; diff --git a/t/extends-non-moo.t b/t/extends-non-moo.t new file mode 100644 index 0000000..bbf7746 --- /dev/null +++ b/t/extends-non-moo.t @@ -0,0 +1,83 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package NonMooClass; + BEGIN { $INC{'NonMooClass.pm'} = __FILE__ } + sub new { + my ($proto, $args) = @_; + bless $args, $proto; + } + + sub to_app { + (shift)->{app}; + } + + package NonMooClass::Child; + BEGIN { $INC{'NonMooClass/Child.pm'} = __FILE__ } + use base qw(NonMooClass); + + sub wrap { + my($class, $app) = @_; + $class->new({app => $app}) + ->to_app; + } + + package NonMooClass::Child::MooExtend; + use Moo; + extends 'NonMooClass::Child'; + + package NonMooClass::Child::MooExtendWithAttr; + use Moo; + extends 'NonMooClass::Child'; + has 'attr' => (is=>'ro'); + + package NonMooClass::Child::MooExtendWithAttr::Extend; + use Moo; + extends 'NonMooClass::Child::MooExtendWithAttr'; + has 'attr2' => (is=>'ro'); +} + +ok my $app = 100, + 'prepared $app'; + +ok $app = NonMooClass::Child->wrap($app), + '$app from $app'; + +is $app, 100, + '$app still 100'; + +ok $app = NonMooClass::Child::MooExtend->wrap($app), + '$app from $app'; + +is $app, 100, + '$app still 100'; + +ok $app = NonMooClass::Child::MooExtendWithAttr->wrap($app), + '$app from $app'; + +is $app, 100, + '$app still 100'; + +ok $app = NonMooClass::Child::MooExtendWithAttr::Extend->wrap($app), + '$app from $app'; + +is $app, 100, + '$app still 100'; + +{ + package BadPrototype; + BEGIN { $INC{'BadPrototype.pm'} = __FILE__ } + sub new () { bless {}, shift } +} +{ + package ExtendBadPrototype; + use Moo; + ::is(::exception { + extends 'BadPrototype'; + has attr1 => (is => 'ro'); + }, undef, 'extending class with prototype on new'); +} + +done_testing(); diff --git a/t/extends-role.t b/t/extends-role.t new file mode 100644 index 0000000..2263b1a --- /dev/null +++ b/t/extends-role.t @@ -0,0 +1,15 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MyRole; + use Moo::Role; +} +{ + package MyClass; + use Moo; + ::isnt ::exception { extends "MyRole"; }, undef, "Can't extend role"; +} + +done_testing; diff --git a/t/foreignbuildargs.t b/t/foreignbuildargs.t new file mode 100644 index 0000000..20fe82f --- /dev/null +++ b/t/foreignbuildargs.t @@ -0,0 +1,53 @@ +use Moo::_strictures; +use Test::More; + +{ + package NonMooClass::Strict; + BEGIN { $INC{'NonMooClass/Strict.pm'} = __FILE__ } + + sub new { + my ($class, $arg) = @_; + die "invalid arguments: " . join(',', @_[2..$#_]) + if @_ > 2; + bless { attr => $arg }, $class; + } + + sub attr { shift->{attr} } + + package NonMooClass::Strict::MooExtend; + use Moo; + extends qw(NonMooClass::Strict); + + sub FOREIGNBUILDARGS { + my ($class, %args) = @_; + return $args{attr2}; + } + + package NonMooClass::Strict::MooExtendWithAttr; + use Moo; + extends qw(NonMooClass::Strict); + + has 'attr2' => ( is => 'ro' ); + + sub FOREIGNBUILDARGS { + my ($class, %args) = @_; + return $args{attr}; + } +} + + +my $non_moo = NonMooClass::Strict->new( 'bar' ); +my $ext_non_moo = NonMooClass::Strict::MooExtend->new( attr => 'bar', attr2 => 'baz' ); +my $ext_non_moo2 = NonMooClass::Strict::MooExtendWithAttr->new( attr => 'bar', attr2 => 'baz' ); + +is $non_moo->attr, 'bar', + "non-moo accepts params"; +is $ext_non_moo->attr, 'baz', + "extended non-moo passes params"; +is $ext_non_moo2->attr, 'bar', + "extended non-moo passes params"; +is $ext_non_moo2->attr2, 'baz', + "extended non-moo has own attributes"; + + +done_testing; diff --git a/t/global-destruction-helper.pl b/t/global-destruction-helper.pl new file mode 100644 index 0000000..ee66528 --- /dev/null +++ b/t/global-destruction-helper.pl @@ -0,0 +1,18 @@ +use Moo::_strictures; +use POSIX (); + +my $exit_value = shift; + +BEGIN { + package Bar; + use Moo; + + sub DEMOLISH { + my ($self, $gd) = @_; + if ($gd) { + POSIX::_exit($exit_value); + } + } +} + +our $bar = Bar->new; diff --git a/t/global_underscore.t b/t/global_underscore.t new file mode 100644 index 0000000..f458c04 --- /dev/null +++ b/t/global_underscore.t @@ -0,0 +1,44 @@ +use Moo::_strictures; +use Test::More; +use lib qw(t/lib); +use InlineModule ( + 'UnderscoreClass' => q{ + package UnderscoreClass; + use Moo; + with qw(UnderscoreRole); + sub c1 { 'c1' }; + 1; + }, + 'UnderscoreRole' => q{ + package UnderscoreRole; + use Moo::Role; + use ClobberUnderscore; + sub r1 { 'r1' }; + 1; + }, + 'ClobberUnderscore' => q{ + package ClobberUnderscore; + sub h1 { 'h1' }; + undef $_; + 1; + }, +); + +use_ok('UnderscoreClass'); + +is( + UnderscoreClass->c1, + 'c1', +); + +is( + UnderscoreClass->r1, + 'r1', +); + +is( + ClobberUnderscore::h1(), + 'h1', +); + +done_testing; diff --git a/t/has-array.t b/t/has-array.t new file mode 100644 index 0000000..6e3c83c --- /dev/null +++ b/t/has-array.t @@ -0,0 +1,44 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +is(exception { + package Local::Test::Role1; + use Moo::Role; + has [qw/ attr1 attr2 /] => (is => 'ro'); +}, undef, 'has \@attrs works in roles'); + +is(exception { + package Local::Test::Class1; + use Moo; + with 'Local::Test::Role1'; + has [qw/ attr3 attr4 /] => (is => 'ro'); +}, undef, 'has \@attrs works in classes'); + +my $obj = new_ok 'Local::Test::Class1' => [ + attr1 => 1, + attr2 => 2, + attr3 => 3, + attr4 => 4, +]; + +can_ok( + $obj, + qw( attr1 attr2 attr3 attr4 ), +); + +like(exception { + package Local::Test::Role2; + use Moo::Role; + has [qw/ attr1 attr2 /] => (is => 'ro', 'isa'); +}, qr/^Invalid options for 'attr1', 'attr2' attribute\(s\): even number of arguments expected, got 3/, + 'correct exception when has given bad parameters in role'); + +like(exception { + package Local::Test::Class2; + use Moo; + has [qw/ attr3 attr4 /] => (is => 'ro', 'isa'); +}, qr/^Invalid options for 'attr3', 'attr4' attribute\(s\): even number of arguments expected, got 3/, + 'correct exception when has given bad parameters in class'); + +done_testing; diff --git a/t/has-before-extends.t b/t/has-before-extends.t new file mode 100644 index 0000000..b7f760e --- /dev/null +++ b/t/has-before-extends.t @@ -0,0 +1,25 @@ +use Moo::_strictures; +use Test::More; + +{ + package Fail1; + + use Moo; + + has 'attr1' => (is => 'ro'); + + package Fail2; + + use Moo; + + has 'attr2' => (is => 'ro'); + + extends 'Fail1'; +} + +my $new = Fail2->new({ attr1 => 'value1', attr2 => 'value2' }); + +is($new->attr1, 'value1', 'inherited attr ok'); +is($new->attr2, 'value2', 'subclass attr ok'); + +done_testing; diff --git a/t/has-plus.t b/t/has-plus.t new file mode 100644 index 0000000..8c317cc --- /dev/null +++ b/t/has-plus.t @@ -0,0 +1,101 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package RollyRole; + + use Moo::Role; + + has f => (is => 'ro', default => sub { 0 }); +} + +{ + package ClassyClass; + + use Moo; + + has f => (is => 'ro', default => sub { 1 }); +} + +{ + package UsesTheRole; + + use Moo; + + with 'RollyRole'; +} + +{ + package UsesTheRole2; + + use Moo; + + with 'RollyRole'; + + has '+f' => (default => sub { 2 }); +} + +{ + + package ExtendsTheClass; + + use Moo; + + extends 'ClassyClass'; + + has '+f' => (default => sub { 3 }); +} + +{ + package BlowsUp; + + use Moo; + + ::like(::exception { has '+f' => () }, qr/\Qhas '+f'/, 'Kaboom'); +} + +{ + package ClassyClass2; + use Moo; + has d => (is => 'ro', default => sub { 4 }); +} + +{ + package MultiClass; + use Moo; + extends 'ClassyClass', 'ClassyClass2'; + ::is(::exception { + has '+f' => (); + }, undef, 'extend attribute from first parent'); + ::like(::exception { + has '+d' => (); + }, qr/no d attribute already exists/, + 'can\'t extend attribute from second parent'); +} + +is(UsesTheRole->new->f, 0, 'role attr'); +is(ClassyClass->new->f, 1, 'class attr'); +is(UsesTheRole2->new->f, 2, 'role attr with +'); +is(ExtendsTheClass->new->f, 3, 'class attr with +'); + +{ + package HasBuilderSub; + use Moo; + has f => (is => 'ro', builder => sub { __PACKAGE__ }); +} + +{ + package ExtendsBuilderSub; + use Moo; + extends 'HasBuilderSub'; + has '+f' => (init_arg => undef); + sub _build_f { __PACKAGE__ } +} + +is +ExtendsBuilderSub->new->_build_f, 'ExtendsBuilderSub', + 'build sub not replaced by +attr'; +is +ExtendsBuilderSub->new->f, 'ExtendsBuilderSub', + 'correct build sub used after +attr'; + +done_testing; diff --git a/t/init-arg.t b/t/init-arg.t new file mode 100644 index 0000000..21763de --- /dev/null +++ b/t/init-arg.t @@ -0,0 +1,108 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Foo; + + use Moo; + + has optional => ( + is => 'rw', + init_arg => 'might_have', + isa => sub { die "isa" if $_[0] % 2 }, + default => sub { 7 }, + ); + + has lazy => ( + is => 'rw', + init_arg => 'workshy', + isa => sub { die "aieee" if $_[0] % 2 }, + default => sub { 7 }, + lazy => 1, + ); +} + +like( + exception { Foo->new }, + qr/\Aisa check for "optional" \(constructor argument: "might_have"\) failed:/, + "isa default" +); + +like( + exception { Foo->new(might_have => 3) }, + qr/\Aisa check for "optional" \(constructor argument: "might_have"\) failed:/, + "isa init_arg", +); + +is( + exception { Foo->new(might_have => 2) }, + undef, "isa init_arg ok" +); + +my $foo = Foo->new(might_have => 2); + +like( + exception { $foo->optional(3) }, + qr/\Aisa check for "optional" failed:/, + "isa accessor", +); + +like( + exception { $foo->lazy }, + qr/\Aisa check for "lazy" failed:/, + "lazy accessor", +); + +like( + exception { $foo->lazy(3) }, + qr/\Aisa check for "lazy" failed:/, + "lazy set isa fail", +); + +is( + exception { $foo->lazy(4) }, + undef, + "lazy set isa ok", +); + +like( + exception { Foo->new(might_have => 2, workshy => 3) }, + qr/\Aisa check for "lazy" \(constructor argument: "workshy"\) failed:/, + "lazy init_arg", +); + +{ + package Bar; + + use Moo; + + has sane_key_name => ( + is => 'rw', + init_arg => 'stupid key name', + isa => sub { die "isa" if $_[0] % 2 }, + required => 1 + ); + has sane_key_name2 => ( + is => 'rw', + init_arg => 'complete\nnonsense\\\'key', + isa => sub { die "isa" if $_[0] % 2 }, + required => 1 + ); +} + +my $bar; +is( + exception { + $bar= Bar->new( + 'stupid key name' => 4, + 'complete\nnonsense\\\'key' => 6 + ) + }, + undef, 'requiring init_arg with spaces and insanity', +); + +is( $bar->sane_key_name, 4, 'key renamed correctly' ); +is( $bar->sane_key_name2, 6, 'key renamed correctly' ); + +done_testing; diff --git a/t/isa-interfere.t b/t/isa-interfere.t new file mode 100644 index 0000000..82b0e49 --- /dev/null +++ b/t/isa-interfere.t @@ -0,0 +1,61 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Moo (); + +BEGIN { + package BaseClass; + + sub new { + my $class = shift; + my $self = bless {}, $class; + return $self; + } +} + +BEGIN { + package ExtraClass; + + sub new { + my $class = shift; + $class->next::method(@_); + } +} + +BEGIN { + package ChildClass; + use Moo; + extends 'BaseClass'; our $EXTEND_FILE = __FILE__; our $EXTEND_LINE = __LINE__; + + unshift our @ISA, 'ExtraClass'; +} + +my $ex = exception { + ChildClass->new; +}; +like $ex, qr{Expected parent constructor of ChildClass to be BaseClass, but found ExtraClass}, + 'Interfering with @ISA after using extends triggers error'; +like $ex, qr{\Q(after $ChildClass::EXTEND_FILE line $ChildClass::EXTEND_LINE)\E}, + ' ... reporting location triggering constructor generation'; + +BEGIN { + package ExtraClass2; + + sub foo { 'garp' } +} + +BEGIN { + package ChildClass2; + use Moo; + extends 'BaseClass'; + + unshift our @ISA, 'ExtraClass2'; +} + +is exception { + ChildClass2->new; +}, undef, + 'Changing @ISA without effecting constructor does not trigger error'; + +done_testing; diff --git a/t/lazy_isa.t b/t/lazy_isa.t new file mode 100644 index 0000000..b438f5c --- /dev/null +++ b/t/lazy_isa.t @@ -0,0 +1,75 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +my $isa_called = 0; +{ + package FooISA; + + use Moo; + + my $isa = sub { + $isa_called++; + die "I want to die" unless $_[0] eq 'live'; + }; + + has a_lazy_attr => ( + is => 'ro', + isa => $isa, + lazy => 1, + builder => '_build_attr', + ); + + has non_lazy => ( + is => 'ro', + isa => $isa, + builder => '_build_attr', + ); + + sub _build_attr { 'die' } +} + +ok my $lives = FooISA->new(a_lazy_attr=>'live', non_lazy=>'live'), + 'expect to live when both attrs are set to live in init'; + +my $called_pre = $isa_called; +$lives->a_lazy_attr; +is $called_pre, $isa_called, 'isa is not called on access when value already exists'; + +like( + exception { FooISA->new(a_lazy_attr=>'live', non_lazy=>'die') }, + qr/I want to die/, + 'expect to die when non lazy is set to die in init', +); + +like( + exception { FooISA->new(a_lazy_attr=>'die', non_lazy=>'die') }, + qr/I want to die/, + 'expect to die when non lazy and lazy is set to die in init', +); + +like( + exception { FooISA->new(a_lazy_attr=>'die', non_lazy=>'live') }, + qr/I want to die/, + 'expect to die when lazy is set to die in init', +); + +like( + exception { FooISA->new() }, + qr/I want to die/, + 'expect to die when both lazy and non lazy are allowed to default', +); + +like( + exception { FooISA->new(a_lazy_attr=>'live') }, + qr/I want to die/, + 'expect to die when lazy is set to live but non lazy is allowed to default', +); + +is( + exception { FooISA->new(non_lazy=>'live') }, + undef, + 'ok when non lazy is set to something valid but lazy is allowed to default', +); + +done_testing; diff --git a/t/lib/ErrorLocation.pm b/t/lib/ErrorLocation.pm new file mode 100644 index 0000000..f3cb64e --- /dev/null +++ b/t/lib/ErrorLocation.pm @@ -0,0 +1,82 @@ +package ErrorLocation; +use Moo::_strictures; +use Test::Builder; +use Carp qw(croak); +use Exporter 'import'; + +our @EXPORT = qw(location_ok); + +my $builder = Test::Builder->new; + +my $gen = 'A000'; +sub location_ok ($$) { + my ($code, $name) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($pre) = $code =~ /\A(.*?)(?:## fail\n.*)?\n?\z/s; + my $fail_line = 1 + $pre =~ tr/\n//; + my $PACKAGE = "LocationTest::_".++$gen; + my $sub = eval qq{ sub { +package $PACKAGE; +#line 1 LocationTestFile +$code + } }; + my $full_trace; + my $last_location; + my $immediate; + my $trace_capture = sub { + my @c = caller; + my ($location) = $_[0] =~ /^.* at (.*? line \d+)\.?$/; + $location ||= sprintf "%s line %s", (caller(0))[1,2]; + if (!$last_location || $last_location ne $location) { + $last_location = $location; + $immediate = $c[1] eq 'LocationTestFile'; + { + local %Carp::Internal; + local %Carp::CarpInternal; + $full_trace = Carp::longmess(''); + } + $full_trace =~ s/\A.*\n//; + $full_trace =~ s/^\t//mg; + $full_trace =~ s/^[^\n]+ called at ${\__FILE__} line [0-9]+\n.*//ms; + if ($c[0] eq 'Carp') { + $full_trace =~ s/.*?(^Carp::)/$1/ms; + } + else { + my ($arg) = @_; + $arg =~ s/\Q at $c[1] line $c[2]\E\.\n\z//; + my $caller = 'CORE::die(' . Carp::format_arg($arg) . ") called at $location\n"; + $full_trace =~ s/\A.*\n/$caller/; + } + $full_trace =~ s{^(.* called at )(\(eval [0-9]+\)(?:\[[^\]]*\])?) line ([0-9]+)\n}{ + my ($prefix, $file, $line) = ($1, $2, $3); + my $i = 0; + while (my @c = caller($i++)) { + if ($c[1] eq $file && $c[2] eq $line) { + $file .= "[$c[0]]"; + last; + } + } + "$prefix$file line $line\n"; + }meg; + $full_trace =~ s/^/ /mg; + } + }; + croak "$name - compile error: $@" + if !$sub; + local $@; + eval { + local $Carp::Verbose = 0; + local $SIG{__WARN__}; + local $SIG{__DIE__} = $trace_capture; + $sub->(); + 1; + } and croak "$name - code did not fail!"; + croak "died directly in test code: $@" + if $immediate; + delete $LocationTest::{"_$gen"}; + my ($location) = $@ =~ /.* at (.*? line \d+)\.?$/; + $builder->is_eq($location, "LocationTestFile line $fail_line", $name) + or $builder->diag(" error:\n $@\n full trace:\n$full_trace"), return !1; +} + +1; diff --git a/t/lib/InlineModule.pm b/t/lib/InlineModule.pm new file mode 100644 index 0000000..388b21f --- /dev/null +++ b/t/lib/InlineModule.pm @@ -0,0 +1,51 @@ +package InlineModule; +use Moo::_strictures; + +BEGIN { + *_HAS_PERLIO = "$]" >= 5.008_000 ? sub(){1} : sub(){0}; +} + +sub import { + my ($class, %modules) = @_; + unshift @INC, inc_hook(%modules); +} + +sub inc_hook { + my (%modules) = @_; + my %files = map { + (my $file = "$_.pm") =~ s{::}{/}g; + $file => $modules{$_}; + } keys %modules; + + sub { + return + unless exists $files{$_[1]}; + my $module = $files{$_[1]}; + if (!defined $module) { + die "Can't locate $_[1] in \@INC (hidden) (\@INC contains: @INC).\n"; + } + inc_module($module); + } +} + +sub inc_module { + my $code = $_[0]; + if (_HAS_PERLIO) { + open my $fh, '<', \$code + or die "error loading module: $!"; + return $fh; + } + else { + my $pos = 0; + my $last = length $code; + return (sub { + return 0 if $pos == $last; + my $next = (1 + index $code, "\n", $pos) || $last; + $_ .= substr $code, $pos, $next - $pos; + $pos = $next; + return 1; + }); + } +} + +1; diff --git a/t/lib/TestEnv.pm b/t/lib/TestEnv.pm new file mode 100644 index 0000000..b08d6e5 --- /dev/null +++ b/t/lib/TestEnv.pm @@ -0,0 +1,10 @@ +package TestEnv; +use strict; +use warnings; + +sub import { + $ENV{$_} = 1 + for grep defined && length && !exists $ENV{$_}, @_[1 .. $#_]; +} + +1; diff --git a/t/load_module.t b/t/load_module.t new file mode 100644 index 0000000..037a2be --- /dev/null +++ b/t/load_module.t @@ -0,0 +1,21 @@ +# this test is replicated to t/load_module_role_tiny.t for Role::Tiny + +use Moo::_strictures; +use Test::More; +use lib 't/lib'; +use Moo::_Utils qw(_load_module); +use InlineModule ( + 'Foo::Bar' => q{ + package Foo::Bar; + sub baz { 1 } + 1; + }, +); + +{ package Foo::Bar::Baz; sub quux { } } + +_load_module("Foo::Bar"); + +ok(eval { Foo::Bar->baz }, 'Loaded module ok'); + +done_testing; diff --git a/t/load_module_error.t b/t/load_module_error.t new file mode 100644 index 0000000..b923017 --- /dev/null +++ b/t/load_module_error.t @@ -0,0 +1,23 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; +use lib 't/lib'; +use InlineModule ( + 'BrokenExtends' => qq{ + package BrokenExtends; + use Moo; + extends "This::Class::Does::Not::Exist::${\int rand 50000}"; + }, + 'BrokenExtends::Child' => q{ + package BrokenExtends::Child; + use Moo; + + extends 'BrokenExtends'; + }, +); + +my $e = exception { require BrokenExtends::Child }; +ok $e, "got a crash"; +unlike $e, qr/Unknown error/, "it came with a useful error message"; + +done_testing; diff --git a/t/load_module_role_tiny.t b/t/load_module_role_tiny.t new file mode 100644 index 0000000..76047cc --- /dev/null +++ b/t/load_module_role_tiny.t @@ -0,0 +1,21 @@ +# this test is replicated to t/load_module.t for Moo::_Utils + +use Moo::_strictures; +use Test::More; +use lib 't/lib'; +use Role::Tiny (); +use InlineModule ( + 'Foo::Bar' => q{ + package Foo::Bar; + sub baz { 1 } + 1; + }, +); + +{ package Foo::Bar::Baz; sub quux { } } + +Role::Tiny::_load_module("Foo::Bar"); + +ok(eval { Foo::Bar->baz }, 'Loaded module ok'); + +done_testing; diff --git a/t/long-package-name.t b/t/long-package-name.t new file mode 100644 index 0000000..f3d4434 --- /dev/null +++ b/t/long-package-name.t @@ -0,0 +1,51 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Some::Class; + use Moo; + has attr1 => (is => 'ro'); +} + +my $max_length = 252; + +my $long_name = "Long::Package::Name::"; +$long_name .= substr("0123456789" x 26, 0, $max_length - length $long_name); + +is exception { + eval qq{ + package $long_name; + use Moo; + has attr2 => (is => 'ro'); + 1; + } or die "$@"; +}, undef, + 'can use Moo in a long package'; + +is exception { + $long_name->new; +}, undef, + 'long package name instantiation works'; + +{ + package AMooClass; + use Moo; + has attr1 => (is => 'ro'); +} + +for (1..7) { + eval qq{ + package LongRole${_}::ABCDEFGHIGKLMNOPQRSTUVWXYZ; + use Moo::Role; + 1; + } or die $@; +} + +is exception { + Moo::Role->create_class_with_roles('AMooClass', + map "LongRole${_}::ABCDEFGHIGKLMNOPQRSTUVWXYZ", 1..7)->new->attr1; +}, undef, + 'generated long class names work'; + +done_testing; diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t new file mode 100644 index 0000000..a87ebd9 --- /dev/null +++ b/t/method-generate-accessor.t @@ -0,0 +1,197 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Method::Generate::Accessor; +use Sub::Quote 'quote_sub'; +use Sub::Defer (); + +my $gen = Method::Generate::Accessor->new; + +{ + package Foo; + use Moo; +} + +{ + package WithOverload; + use overload '&{}' => sub { sub { 5 } }, fallback => 1; + sub new { bless {} } +} + +$gen->generate_method('Foo' => 'one' => { is => 'ro' }); + +$gen->generate_method('Foo' => 'two' => { is => 'rw' }); + +like( + exception { $gen->generate_method('Foo' => 'three' => {}) }, + qr/Must have an is/, 'No is rejected' +); + +like( + exception { $gen->generate_method('Foo' => 'three' => { is => 'purple' }) }, + qr/Unknown is purple/, 'is purple rejected' +); + +is(exception { + $gen->generate_method('Foo' => 'three' => { is => 'bare', predicate => 1 }); +}, undef, 'generating bare accessor works'); + +ok(Foo->can('has_three'), 'bare accessor will still generate predicate'); + +like( + exception { $gen->generate_method('Foo' => 'four' => { is => 'ro', coerce => 5 }) }, + qr/Invalid coerce/, "coerce - scalar rejected" +); + +is( + exception { $gen->generate_method('Foo' => 'four' => { is => 'ro', default => 5 }) }, + undef, "default - non-ref scalar accepted" +); + +foreach my $setting (qw( default coerce )) { + + like( + exception { $gen->generate_method('Foo' => 'five' => { allow_overwrite => 1, is => 'ro', $setting => [] }) }, + qr/Invalid $setting/, "$setting - arrayref rejected" + ); + + like( + exception { $gen->generate_method('Foo' => 'five' => { allow_overwrite => 1, is => 'ro', $setting => Foo->new }) }, + qr/Invalid $setting/, "$setting - non-code-convertible object rejected" + ); + + is( + exception { $gen->generate_method('Foo' => 'six' => { allow_overwrite => 1, is => 'ro', $setting => sub { 5 } }) }, + undef, "$setting - coderef accepted" + ); + + is( + exception { $gen->generate_method('Foo' => 'seven' => { allow_overwrite => 1, is => 'ro', $setting => bless sub { 5 } => 'Blah' }) }, + undef, "$setting - blessed sub accepted" + ); + + is( + exception { $gen->generate_method('Foo' => 'eight' => { allow_overwrite => 1, is => 'ro', $setting => WithOverload->new }) }, + undef, "$setting - object with overloaded ->() accepted" + ); + + like( + exception { $gen->generate_method('Foo' => 'nine' => { allow_overwrite => 1, is => 'ro', $setting => bless {} => 'Blah' }) }, + qr/Invalid $setting/, "$setting - object rejected" + ); +} + +is( + exception { $gen->generate_method('Foo' => 'ten' => { is => 'ro', builder => '_build_ten' }) }, + undef, 'builder - string accepted', +); + +is( + exception { $gen->generate_method('Foo' => 'eleven' => { is => 'ro', builder => sub {} }) }, + undef, 'builder - coderef accepted' +); + +like( + exception { $gen->generate_method('Foo' => 'twelve' => { is => 'ro', builder => 'build:twelve' }) }, + qr/Invalid builder/, 'builder - invalid name rejected', +); + +is( + exception { $gen->generate_method('Foo' => 'thirteen' => { is => 'ro', builder => 'build::thirteen' }) }, + undef, 'builder - fully-qualified name accepted', +); + +is( + exception { $gen->generate_method('Foo' => 'fifteen' => { is => 'lazy', builder => sub {15} }) }, + undef, 'builder - coderef accepted' +); + +is( + exception { $gen->generate_method('Foo' => 'sixteen' => { is => 'lazy', builder => quote_sub q{ 16 } }) }, + undef, 'builder - quote_sub accepted' +); + +{ + my $methods = $gen->generate_method('Foo' => 'seventeen' => { is => 'lazy', default => 0 }, { no_defer => 0 }); + ok Sub::Defer::defer_info($methods->{seventeen}), 'quote opts are passed on'; +} + +ok !$gen->is_simple_attribute('attr', { builder => 'build_attr' }), + "attribute with builder isn't simple"; +ok $gen->is_simple_attribute('attr', { clearer => 'clear_attr' }), + "attribute with clearer is simple"; + +{ + my ($code, $cap) = $gen->generate_get_default('$self', 'attr', + { default => 5 }); + is eval $code, 5, 'non-ref default code works'; + is_deeply $cap, {}, 'non-ref default has no captures'; +} + +{ + my ($code, $cap) = $gen->generate_simple_get('$self', 'attr', + { default => 1 }); + my $self = { attr => 5 }; + is eval $code, 5, 'simple get code works'; + is_deeply $cap, {}, 'simple get code has no captures'; +} + +{ + my ($code, $cap) = $gen->generate_coerce('attr', '$value', + quote_sub q{ $_[0] + 1 }); + my $value = 5; + is eval $code, 6, 'coerce from quoted sub code works'; + is_deeply $cap, {}, 'coerce from quoted sub has no captures'; +} + +{ + my ($code, $cap) = $gen->generate_trigger('attr', '$self', '$value', + quote_sub q{ $_[0]{trigger} = $_[1] }); + my $self = {}; + my $value = 5; + eval $code; + is $self->{trigger}, 5, 'trigger from quoted sub code works'; + is_deeply $cap, {}, 'trigger from quoted sub has no captures'; +} + +{ + my ($code, $cap) = $gen->generate_isa_check('attr', '$value', + quote_sub q{ die "bad value: $_[0]" unless $_[0] && $_[0] == 5 }); + my $value = 4; + eval $code; + like $@, qr/bad value: 4/, 'isa from quoted sub code works'; + is_deeply $cap, {}, 'isa from quoted sub has no captures'; +} + +{ + my ($code, $cap) = $gen->generate_populate_set( + '$obj', 'attr', { is => 'ro' }, undef, undef, 'attr', + ); + is $code, '', 'populate without eager default or test is blank'; + is_deeply $cap, {}, ' ... and has no captures'; +} + +my $foo = Foo->new; +$foo->{one} = 1; + +is($foo->one, 1, 'ro reads'); +ok(exception { $foo->one(-3) }, 'ro dies on write attempt'); +is($foo->one, 1, 'ro does not write'); + +is($foo->two, undef, 'rw reads'); +$foo->two(-3); +is($foo->two, -3, 'rw writes'); + +is($foo->fifteen, 15, 'builder installs code sub'); +is($foo->_build_fifteen, 15, 'builder installs code sub under the correct name'); + +is($foo->sixteen, 16, 'builder installs quote_sub'); + +{ + my $var = $gen->_sanitize_name('erk-qro yuf (fid)'); + eval qq{ my \$$var = 5; \$var }; + is $@, '', '_sanitize_name gives valid identifier'; +} + +done_testing; diff --git a/t/method-generate-constructor.t b/t/method-generate-constructor.t new file mode 100644 index 0000000..891b6ce --- /dev/null +++ b/t/method-generate-constructor.t @@ -0,0 +1,96 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Method::Generate::Constructor; +use Method::Generate::Accessor; + +my $gen = Method::Generate::Constructor->new( + accessor_generator => Method::Generate::Accessor->new +); + +$gen->generate_method('Foo', 'new', { + one => { }, + two => { init_arg => undef }, + three => { init_arg => 'THREE' } +}); + +my $first = Foo->new({ + one => 1, + two => 2, + three => -75, + THREE => 3, + four => 4, +}); + +is_deeply( + { %$first }, { one => 1, three => 3 }, + 'init_arg handling ok' +); + +$gen->generate_method('Bar', 'new' => { + one => { required => 1 }, + three => { init_arg => 'THREE', required => 1 } +}); + +like( + exception { Bar->new }, + qr/Missing required arguments: THREE, one/, + 'two missing args reported correctly' +); + +like( + exception { Bar->new(THREE => 3) }, + qr/Missing required arguments: one/, + 'one missing arg reported correctly' +); + +is( + exception { Bar->new(one => 1, THREE => 3) }, + undef, + 'pass with both required args' +); + +is( + exception { Bar->new({ one => 1, THREE => 3 }) }, + undef, + 'hashrefs also supported' +); + +is( + exception { $first->new(one => 1, THREE => 3) }, + undef, + 'calling ->new on an object works' +); + +like( + exception { $gen->register_attribute_specs('seventeen' + => { is => 'ro', init_arg => undef, required => 1 }) }, + qr/You cannot have a required attribute/, + 'required not allowed with init_arg undef' +); + +is( + exception { $gen->register_attribute_specs('eighteen' + => { is => 'ro', init_arg => undef, required => 1, default => 'foo' }) }, + undef, + 'required allowed with init_arg undef if given a default' +); + +is ref($gen->current_constructor('Bar')), 'CODE', + 'can find constructor'; + +{ + package Baz; + sub baz {}; +} + +is $gen->current_constructor('Baz'), undef, + 'nonexistent constructor returns undef'; + +{ + is $gen->_cap_call('welp'), 'welp', + "_cap_call returns code"; +} + +done_testing; diff --git a/t/modify_lazy_handlers.t b/t/modify_lazy_handlers.t new file mode 100644 index 0000000..149154c --- /dev/null +++ b/t/modify_lazy_handlers.t @@ -0,0 +1,53 @@ +use Moo::_strictures; +use Test::More; + +BEGIN { + package ClassicObject; + + sub new { + my ($class, %args) = @_; + bless \%args, 'ClassicObject'; + } + + sub connect { 'a' } +} + +BEGIN { + package MooObjectWithDelegate; + use Scalar::Util (); + use Moo; + + has 'delegated' => ( + is => 'ro', + isa => sub { + do { $_[0] && Scalar::Util::blessed($_[0]) } + or die "Not an Object!"; + }, + lazy => 1, + builder => '_build_delegated', + handles => [qw/connect/], + ); + + sub _build_delegated { + my $self = shift; + return ClassicObject->new; + } + + around 'connect', sub { + my ($orig, $self, @args) = @_; + return $self->$orig(@args) . 'b'; + }; + + around 'connect', sub { + my ($orig, $self, @args) = @_; + return $self->$orig(@args) . 'c'; + }; +} + +ok my $moo_object = MooObjectWithDelegate->new, + 'got object'; + +is $moo_object->connect, 'abc', + 'got abc'; + +done_testing; diff --git a/t/moo-accessors.t b/t/moo-accessors.t new file mode 100644 index 0000000..c79ad66 --- /dev/null +++ b/t/moo-accessors.t @@ -0,0 +1,61 @@ +use Moo::_strictures; +use Test::More; +use Sub::Quote qw(quote_sub); + +{ + package Foo; + + use Moo; + + has one => (is => 'ro'); + has two => (is => 'rw', init_arg => undef); + has three => (is => 'ro', init_arg => 'THREE', required => 1); + + package Bar; + + use Moo::Role; + + has four => (is => 'ro'); + ::quote_sub 'Bar::quoted' => '1'; + + package Baz; + + use Moo; + + extends 'Foo'; + + with 'Bar'; + + has five => (is => 'rw'); +} + +my $foo = Foo->new( + one => 1, + THREE => 3 +); + +is_deeply( + { %$foo }, { one => 1, three => 3 }, 'simple class ok' +); + +my $baz = Baz->new( + one => 1, + THREE => 3, + four => 4, + five => 5, +); + +is_deeply( + { %$baz }, { one => 1, three => 3, four => 4, five => 5 }, + 'subclass with role ok' +); + +ok(eval { Foo->meta->make_immutable }, 'make_immutable returns true'); +ok(!$INC{"Moose.pm"}, "Didn't load Moose"); + +$baz->quoted; + +is +$baz->can('quoted'), Bar->can('quoted'), + 'accessor from role is undeferred in consuming class'; + +done_testing unless caller; diff --git a/t/moo-c3.t b/t/moo-c3.t new file mode 100644 index 0000000..63b7ba0 --- /dev/null +++ b/t/moo-c3.t @@ -0,0 +1,37 @@ +use Moo::_strictures; +use Test::More; + +{ + package MyClassRoot; + use Moo; + has root => (is => 'ro'); +} + +{ + package MyClassLeft; + use Moo; + extends 'MyClassRoot'; + has left => (is => 'ro'); +} + +{ + package MyClassRight; + use Moo; + extends 'MyClassRoot'; + has right => (is => 'ro'); +} + +{ + package MyClassChild; + use Moo; + extends 'MyClassLeft', 'MyClassRight'; + has child => (is => 'ro'); +} + +my $o = MyClassChild->new(root => 1, left => 2, right => 3, child => 4); +is $o->root, 1, 'constructor populates root class attribute'; +is $o->left, 2, 'constructor populates left parent attribute'; +is $o->right, undef, 'constructor doesn\'t populate right parent attribute'; +is $o->child, 4, 'constructor populates child class attribute'; + +done_testing; diff --git a/t/moo-object.t b/t/moo-object.t new file mode 100644 index 0000000..2a8a044 --- /dev/null +++ b/t/moo-object.t @@ -0,0 +1,55 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MyClass; + use base 'Moo::Object'; +} + +{ + package MyClass2; + use base 'Moo::Object'; + sub BUILD { } +} + +is_deeply +MyClass->BUILDARGS({foo => 'bar'}), {foo => 'bar'}, + 'BUILDARGS: hashref accepted'; +is_deeply +MyClass->BUILDARGS(foo => 'bar'), {foo => 'bar'}, + 'BUILDARGS: hash accepted'; +like + exception { MyClass->BUILDARGS('foo') }, + qr/Single parameters to new\(\) must be a HASH ref/, + 'BUILDARGS: non-hashref single element rejected'; +like + exception { MyClass->BUILDARGS(foo => 'bar', 5) }, + qr/You passed an odd number of arguments/, + 'BUILDARGS: odd number of elements rejected'; + +is +MyClass->new({foo => 'bar'})->{foo}, undef, + 'arbitrary attributes not stored when no BUILD exists'; +my $built = 0; +*MyClass::BUILD = sub { $built++ }; +is +MyClass->new({foo => 'bar'})->{foo}, undef, + 'arbitrary attributes not stored second time when no BUILD exists'; +is $built, 0, 'BUILD only checked for once'; + +is +MyClass2->new({foo => 'bar'})->{foo}, undef, + 'arbitrary attributes not stored when BUILD exists'; +is +MyClass2->new({foo => 'bar'})->{foo}, undef, + 'arbitrary attributes not stored second time when BUILD exists'; + +ok !MyClass->does('MyClass2'), 'does returns false for other class'; +is $INC{'Role/Tiny.pm'}, undef, " ... and doesn't load Role::Tiny"; + +{ + my $meta = MyClass->meta; + $meta->make_immutable; + is $INC{'Moo/HandleMoose.pm'}, undef, + "->meta->make_immutable doesn't load HandleMoose"; + $meta->DESTROY; +} +is $INC{'Moo/HandleMoose.pm'}, undef, + "destroying fake metaclass doesn't load HandleMoose"; + +done_testing; diff --git a/t/moo-utils-_name_coderef.t b/t/moo-utils-_name_coderef.t new file mode 100644 index 0000000..7c268d6 --- /dev/null +++ b/t/moo-utils-_name_coderef.t @@ -0,0 +1,20 @@ +use Moo::_strictures; +use Test::More; +use List::Util; # List::Util provides Sub::Util::set_subname, so load it early +use Scalar::Util; # to make sure it doesn't warn about our fake subs + +BEGIN { + no warnings 'redefine'; + $INC{'Sub/Name.pm'} ||= 1; + defined &Sub::Name::subname or *Sub::Name::subname = sub { $_[1] }; + $INC{'Sub/Util.pm'} ||= 1; + defined &Sub::Util::set_subname or *Sub::Util::set_subname = sub { $_[1] }; +} + +use Moo::_Utils (); + +ok( Moo::_Utils::_CAN_SUBNAME, + "_CAN_SUBNAME is true when both Sub::Name and Sub::Util are loaded" +); + +done_testing; diff --git a/t/moo-utils-_subname.t b/t/moo-utils-_subname.t new file mode 100644 index 0000000..2e9edd7 --- /dev/null +++ b/t/moo-utils-_subname.t @@ -0,0 +1,14 @@ +use Moo::_strictures; +use lib 't/lib'; +use InlineModule + 'Sub::Name' => undef, + 'Sub::Util' => undef, +; +use Test::More; + +use Moo::_Utils (); + +my $sub = Moo::_Utils::_subname 'Some::Sub', sub { 5 }; +is $sub->(), 5, '_subname runs even without Sub::Name or Sub::Util'; + +done_testing; diff --git a/t/moo-utils.t b/t/moo-utils.t new file mode 100644 index 0000000..d256501 --- /dev/null +++ b/t/moo-utils.t @@ -0,0 +1,83 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; +use Moo::_Utils; +use lib 't/lib'; +use InlineModule ( + 'Broken::Class' => q{ + use strict; + use warnings; + my $f = flub; + }, +); + +{ + my @warn; + local $SIG{__WARN__} = sub { push @warn, @_ }; + is exception { + ok !_maybe_load_module('Broken::Class'), + '_maybe_load_module returns false for broken modules'; + }, undef, "_maybe_load_module doesn't die on broken modules"; + like $warn[0], qr/Broken::Class exists but failed to load with error/, + '_maybe_load_module errors become warnings'; + _maybe_load_module('Broken::Class'); + is scalar @warn, 1, + '_maybe_load_module only warns once per module'; + ok !_maybe_load_module('Missing::Module::A'.int rand 10**10), + '_maybe_load_module returns false for missing module'; + is scalar @warn, 1, + " ... and doesn't warn"; +} + +{ + { + package MooTest::Module::WithVariable; + our $VARIABLE = 219; + } + like exception { Moo::_Utils::_load_module('MooTest::Module::WithVariable') }, + qr{^Can't locate MooTest/Module/WithVariable\.pm }, + '_load_module: inline package with only variable not treated as loaded'; + + { + package MooTest::Module::WithSub; + sub glorp { $_[0] + 1 } + } + is exception { Moo::_Utils::_load_module('MooTest::Module::WithSub') }, undef, + '_load_module: inline package with sub treated as loaded'; + + { + package MooTest::Module::WithConstant; + use constant GORP => "GLUB"; + } + is exception { Moo::_Utils::_load_module('MooTest::Module::WithConstant') }, undef, + '_load_module: inline package with constant treated as loaded'; + + { + package MooTest::Module::WithListConstant; + use constant GORP => "GLUB", "BOGGLE"; + } + is exception { Moo::_Utils::_load_module('MooTest::Module::WithListConstant') }, undef, + '_load_module: inline package with constant treated as loaded'; + + { + package MooTest::Module::WithBEGIN; + my $var; + BEGIN { $var = 1 } + } + like exception { Moo::_Utils::_load_module('MooTest::Module::WithBEGIN') }, + qr{^Can't locate MooTest/Module/WithBEGIN\.pm }, + '_load_module: inline package with only BEGIN not treated as loaded'; + + { + package MooTest::Module::WithSubPackage; + package MooTest::Module::WithSubPackage::SubPackage; + our $grop = 1; + sub grop { 1 } + } + like exception { Moo::_Utils::_load_module('MooTest::Module::WithSubPackage') }, + qr{^Can't locate MooTest/Module/WithSubPackage\.pm }, + '_load_module: inline package with sub package not treated as loaded'; + +} + +done_testing; diff --git a/t/moo.t b/t/moo.t new file mode 100644 index 0000000..da0b94b --- /dev/null +++ b/t/moo.t @@ -0,0 +1,106 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MyClass0; + + BEGIN { our @ISA = 'ZeroZero' } + + use Moo; +} + +BEGIN { + is( + $INC{'Moo/Object.pm'}, undef, + 'Object.pm not loaded if not required' + ); +} + +{ + package MyClass1; + + use Moo; +} + +is_deeply( + [ @MyClass1::ISA ], [ 'Moo::Object' ], 'superclass defaulted' +); + +{ + package MyClass2; + + use base qw(MyClass1); + use Moo; +} + +is_deeply( + [ @MyClass2::ISA ], [ 'MyClass1' ], 'prior superclass left alone' +); + +{ + package MyClass3; + + use Moo; + + extends 'MyClass2'; +} + +is_deeply( + [ @MyClass3::ISA ], [ 'MyClass2' ], 'extends sets superclass' +); + +{ package WhatTheFlyingFornication; sub wtff {} } + +{ + package MyClass4; + + use Moo; + + extends 'WhatTheFlyingFornication'; + + extends qw(MyClass2 MyClass3); +} + +is_deeply( + [ @MyClass4::ISA ], [ qw(MyClass2 MyClass3) ], 'extends overwrites' +); + +{ + package MyClass5; + + use Moo; + + sub foo { 'foo' } + + around foo => sub { my $orig = shift; $orig->(@_).' with around' }; + + ::like ::exception { + around bar => sub { 'bar' }; + }, qr/not found/, + 'error thrown when modifiying missing method'; +} + +is(MyClass5->foo, 'foo with around', 'method modifier'); + +{ + package MyClass6; + use Moo; + sub new { + bless {}, $_[0]; + } +} + +{ + package MyClass7; + use Moo; + + ::is ::exception { + extends 'MyClass6'; + has foo => (is => 'ro'); + __PACKAGE__->new; + }, undef, + 'can extend Moo class with overridden new'; +} + +done_testing; diff --git a/t/mutual-requires.t b/t/mutual-requires.t new file mode 100644 index 0000000..740a2fa --- /dev/null +++ b/t/mutual-requires.t @@ -0,0 +1,44 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +is exception { + package RoleA; + use Moo::Role; + requires 'method_b'; + requires 'attr_b'; + sub method_a {} + has attr_a => (is => 'ro'); +}, undef, 'define role a'; + +is exception { + package RoleB; + use Moo::Role; + requires 'method_a'; + requires 'attr_a'; + sub method_b {} + has attr_b => (is => 'ro'); +}, undef, 'define role a'; + +is exception { + package RoleC; + use Moo::Role; + with 'RoleA', 'RoleB'; + 1; +}, undef, 'compose roles with mutual requires into role'; + +is exception { + package PackageWithPrecomposed; + use Moo; + with 'RoleC'; + 1; +}, undef, 'compose precomposed roles into package'; + +is exception { + package PackageWithCompose; + use Moo; + with 'RoleA', 'RoleB'; + 1; +}, undef, 'compose roles with mutual requires into package'; + +done_testing; diff --git a/t/no-build.t b/t/no-build.t new file mode 100644 index 0000000..6cdc4cb --- /dev/null +++ b/t/no-build.t @@ -0,0 +1,66 @@ +use Moo::_strictures; +use Test::More; +use Moo::_mro; + +BEGIN { + package Class::Diminutive; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + my $no_build = delete $args->{__no_BUILD__}; + my $self = bless { %$args }, $class; + $self->BUILDALL + unless $no_build; + return $self; + } + sub BUILDARGS { + my $class = shift; + my %args = @_ % 2 ? %{$_[0]} : @_; + return \%args; + } + sub BUILDALL { + my $self = shift; + my $class = ref $self; + my @builds = + grep { defined } + map {; no strict 'refs'; *{$_.'::BUILD'}{CODE} } + @{mro::get_linear_isa($class)}; + for my $build (@builds) { + $self->$build; + } + } +} + +BEGIN { + package TestClass1; + + our @ISA = ('Class::Diminutive'); + sub BUILD { + $_[0]->{build_called}++; + } + sub BUILDARGS { + my $class = shift; + my $args = $class->SUPER::BUILDARGS(@_); + $args->{no_build_used} = $args->{__no_BUILD__}; + return $args; + } +} + +my $o = TestClass1->new; +is $o->{build_called}, 1, 'mini class builder working'; + +BEGIN { + package TestClass2; + use Moo; + extends 'TestClass1'; +} + +my $o2 = TestClass2->new; +is $o2->{build_called}, 1, 'BUILD still called when extending mini class builder'; +is $o2->{no_build_used}, 1, '__no_BUILD__ was passed to mini builder'; + +my $o3 = TestClass2->new({__no_BUILD__ => 1}); +is $o3->{build_called}, undef, '__no_BUILD__ inhibits Moo calling BUILD'; + +done_testing; diff --git a/t/no-moo.t b/t/no-moo.t new file mode 100644 index 0000000..28d4422 --- /dev/null +++ b/t/no-moo.t @@ -0,0 +1,106 @@ +use Moo::_strictures; +use Test::More; + +{ + package Spoon; + + use Moo; + + no warnings 'redefine'; + + sub has { "has!" } + + no Moo; +} + +{ + package Roller; + + use Moo::Role; + + no warnings 'redefine'; + + sub with { "with!" } + + no Moo::Role; +} + +{ + package NoMooClass; + + no warnings 'redefine'; + + sub has { "has!" } + + my %stash = %{Moo::_Utils::_getstash(__PACKAGE__)}; + Moo->unimport; + my %stash2 = %{Moo::_Utils::_getstash(__PACKAGE__)}; + main::is_deeply(\%stash, \%stash2, "stash of non-Moo class remains untouched"); +} + +{ + package GlobalConflict; + + use Moo; + + no warnings 'redefine'; + + sub has { "has!" } + + no Moo; + + our $around = "has!"; + + no Moo; +} + +{ + package RollerTiny; + + use Role::Tiny; + + no warnings 'redefine'; + + sub with { "with!" } + + my %stash = %{Moo::_Utils::_getstash(__PACKAGE__)}; + Moo::Role->unimport; + my %stash2 = %{Moo::_Utils::_getstash(__PACKAGE__)}; + main::is_deeply(\%stash, \%stash2, "stash of non-Moo role remains untouched"); +} + +{ + package GlobalConflict2; + + use Moo; + + no warnings 'redefine'; + + our $after = "has!"; + sub has { $after } + + no Moo; +} + +ok(!Spoon->can('extends'), 'extends cleaned'); +is(Spoon->has, "has!", 'has left alone'); + +ok(!Roller->can('has'), 'has cleaned'); +is(Roller->with, "with!", 'with left alone'); + +is(NoMooClass->has, "has!", 'has left alone'); + +ok(!GlobalConflict->can('extends'), 'extends cleaned'); +is(GlobalConflict->has, "has!", 'has left alone'); + +is($GlobalConflict::around, "has!", 'package global left alone'); + +ok(RollerTiny->can('around'), 'around left alone'); +is(RollerTiny->with, "with!", 'with left alone'); + +ok(!GlobalConflict2->can('extends'), 'extends cleaned'); +is(GlobalConflict2->has, "has!", 'has left alone'); + +is($GlobalConflict2::after, "has!", 'package global left alone'); + +done_testing; diff --git a/t/non-moo-extends-c3.t b/t/non-moo-extends-c3.t new file mode 100644 index 0000000..d6116d6 --- /dev/null +++ b/t/non-moo-extends-c3.t @@ -0,0 +1,62 @@ +use Moo::_strictures; +use Test::More; +use Moo (); +use Moo::_mro; + +{ + package Foo; + + use mro 'c3'; + + sub new { + my ($class, $rest) = @_; + return bless {%$rest}, $class; + } +} + +{ + package Foo::AddCD; + + use base 'Foo'; + + sub new { + my ($class, $rest) = @_; + $rest->{c} = 'd'; + return $class->next::method($rest); + } +} + +{ + package Foo::AddEF; + + use base 'Foo'; + + sub new { + my ($class, $rest) = @_; + $rest->{e} = 'f'; + return $class->next::method($rest); + } +} + +{ + package Foo::Parent; + + use Moo; + use mro 'c3'; + extends 'Foo::AddCD', 'Foo'; +} + +{ + package Foo::Parent::Child; + + use Moo; + use mro 'c3'; + extends 'Foo::AddEF', 'Foo::Parent'; +} + +my $foo = Foo::Parent::Child->new({a => 'b'}); +ok exists($foo->{a}) && $foo->{a} eq 'b', 'has basic attrs'; +ok exists($foo->{c}) && $foo->{c} eq 'd', 'AddCD works'; +ok exists($foo->{e}) && $foo->{e} eq 'f', 'AddEF works'; + +done_testing; diff --git a/t/non-moo-extends.t b/t/non-moo-extends.t new file mode 100644 index 0000000..34bb011 --- /dev/null +++ b/t/non-moo-extends.t @@ -0,0 +1,110 @@ +use Moo::_strictures; +use Test::More; + +{ + package ClassA; + use Moo; + + has 'foo' => ( is => 'ro'); + has built => (is => 'rw', default => 0); + + sub BUILD { + $_[0]->built($_[0]->built+1); + } +} + +{ + package ClassB; + our @ISA = 'ClassA'; + sub blorp {}; + sub new { + $_[0]->SUPER::new(@_[1..$#_]); + } +} + +{ + package ClassC; + use Moo; + extends 'ClassB'; + has bar => (is => 'ro'); +} + +{ + package ClassD; + our @ISA = 'ClassC'; +} + +my $o = ClassD->new(foo => 1, bar => 2); +isa_ok $o, 'ClassD'; +is $o->foo, 1, 'superclass attribute has correct value'; +is $o->bar, 2, 'subclass attribute has correct value'; +is $o->built, 1, 'BUILD called correct number of times'; + +{ + package ClassE; + sub new { + return ClassF->new; + } +} + +{ + package ClassF; + use Moo; + extends 'Moo::Object', 'ClassE'; +} + +{ + my $o = eval { ClassF->new }; + ok $o, + 'explicit inheritence from Moo::Object works around broken constructor' + or diag $@; + isa_ok $o, 'ClassF'; +} + +{ + package ClassG; + use Sub::Defer; + defer_sub __PACKAGE__.'::new' => sub { sub { bless {}, $_[0] } }; +} + +{ + package ClassH; + use Moo; + extends 'ClassG'; +} + +{ + my $o = eval { ClassH->new }; + ok $o, + 'inheriting from non-Moo with deferred new works' + or diag $@; + isa_ok $o, 'ClassH'; +} + +{ + package ClassI; + sub new { + my $self = shift; + my $class = ref $self ? ref $self : $self; + bless { + (ref $self ? %$self : ()), + @_, + }, $class; + } +} + +{ + package ClassJ; + use Moo; + extends 'ClassI'; + has 'attr' => (is => 'ro'); +} + +{ + my $o1 = ClassJ->new(attr => 1); + my $o2 = $o1->new; + is $o2->attr, 1, + 'original invoker passed to parent new'; +} + +done_testing; diff --git a/t/not-both.t b/t/not-both.t new file mode 100644 index 0000000..b974c17 --- /dev/null +++ b/t/not-both.t @@ -0,0 +1,44 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Moo (); +use Moo::Role (); + +{ + like exception { + package ZZZ; + Role::Tiny->import; + Moo->import; + }, qr{Cannot import Moo into a role}, + "can't import Moo into a Role::Tiny role"; +} + +{ + like exception { + package XXX; + Moo->import; + Moo::Role->import; + }, qr{Cannot import Moo::Role into a Moo class}, + "can't import Moo::Role into a Moo class"; +} + +{ + like exception { + package YYY; + Moo::Role->import; + Moo->import; + }, qr{Cannot import Moo into a role}, + "can't import Moo into a Moo role"; +} + +{ + is exception { + package FFF; + $Moo::MAKERS{+__PACKAGE__} = {}; + Moo::Role->import; + }, undef, + "Moo::Role can be imported into a package with fake MAKERS"; +} + +done_testing; diff --git a/t/not-methods.t b/t/not-methods.t new file mode 100644 index 0000000..8dc6fd4 --- /dev/null +++ b/t/not-methods.t @@ -0,0 +1,64 @@ +use Moo::_strictures; +use Test::More; + +BEGIN { + package FooClass; + sub early { 1 } + use Moo; + sub late { 2 } +} + +BEGIN { + is_deeply + [sort keys %{Moo->_concrete_methods_of('FooClass')}], + [qw(late)], + 'subs created before use Moo are not methods'; +} + +BEGIN { + package BarClass; + sub early { 1 } + use Moo; + sub late { 2 } + no warnings 'redefine'; + sub early { 3 } +} + +BEGIN { + is_deeply + [sort keys %{Moo->_concrete_methods_of('BarClass')}], + [qw(early late)], + 'only same subrefs created before use Moo are not methods'; +} + +BEGIN { + package FooRole; + sub early { 1 } + use Moo::Role; + sub late { 2 } +} + +BEGIN { + is_deeply + [sort keys %{Moo::Role->_concrete_methods_of('FooRole')}], + [qw(late)], + 'subs created before use Moo::Role are not methods'; +} + +BEGIN { + package BarRole; + sub early { 1 } + use Moo::Role; + sub late { 2 } + no warnings 'redefine'; + sub early { 3 } +} + +BEGIN { + is_deeply + [sort keys %{Moo::Role->_concrete_methods_of('BarRole')}], + [qw(early late)], + 'only same subrefs created before use Moo::Role are not methods'; +} + +done_testing; diff --git a/t/overloaded-coderefs.t b/t/overloaded-coderefs.t new file mode 100644 index 0000000..5bdf1a7 --- /dev/null +++ b/t/overloaded-coderefs.t @@ -0,0 +1,75 @@ +use Moo::_strictures; +use Test::More; + +my $codified = 0; +{ + package Dark::Side; + use overload + q[&{}] => sub { $codified++; shift->to_code }, + fallback => 1; + sub new { + my $class = shift; + my $code = shift; + bless \$code, $class; + } + sub to_code { + my $self = shift; + eval "sub { $$self }"; + } +} + +{ + package The::Force; + use Sub::Quote; + use base 'Dark::Side'; + sub to_code { + my $self = shift; + return quote_sub $$self; + } +} + +my $darkside = Dark::Side->new('my $dummy = "join the dark side"; $_[0] * 2'); +is($darkside->(6), 12, 'check Dark::Side coderef'); + +my $theforce = The::Force->new('my $dummy = "use the force Luke"; $_[0] * 2'); +is($theforce->(6), 12, 'check The::Force coderef'); + +my $luke = The::Force->new('my $z = "I am your father"'); +{ + package Doubleena; + use Moo; + has a => (is => "rw", coerce => $darkside, isa => sub { 1 }); + has b => (is => "rw", coerce => $theforce, isa => $luke); +} + +my $o = Doubleena->new(a => 11, b => 12); +is($o->a, 22, 'non-Sub::Quoted inlined coercion overload works'); +is($o->b, 24, 'Sub::Quoted inlined coercion overload works'); +my $codified_before = $codified; +$o->a(5); +is($codified_before, $codified, "repeated calls to accessor don't re-trigger overload"); + +use B::Deparse; +my $constructor = B::Deparse->new->coderef2text(Doubleena->can('new')); + +like($constructor, qr{use the force Luke}, 'Sub::Quoted coercion got inlined'); +unlike($constructor, qr{join the dark side}, 'non-Sub::Quoted coercion was not inlined'); +like($constructor, qr{I am your father}, 'Sub::Quoted isa got inlined'); + +require Scalar::Util; +is( + Scalar::Util::refaddr($luke), + Scalar::Util::refaddr( + Moo->_constructor_maker_for("Doubleena")->all_attribute_specs->{"b"}{"isa"} + ), + '$spec->{isa} reference is not mutated', +); +is( + Scalar::Util::refaddr($theforce), + Scalar::Util::refaddr( + Moo->_constructor_maker_for("Doubleena")->all_attribute_specs->{"b"}{"coerce"} + ), + '$spec->{coerce} reference is not mutated', +); + +done_testing; diff --git a/t/overridden-core-funcs.t b/t/overridden-core-funcs.t new file mode 100644 index 0000000..ca8d92c --- /dev/null +++ b/t/overridden-core-funcs.t @@ -0,0 +1,79 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + + +BEGIN { + package AddOverrides; + $INC{"AddOverrides.pm"} = __FILE__; + use Carp (); + sub import { + my $package = caller; + for my $sub ( + 'defined', + 'join', + 'ref', + 'die', + 'shift', + 'sort', + 'undef', + ) { + my $proto = prototype "CORE::$sub"; + no strict 'refs'; + *{"${package}::$sub"} = \&{"${package}::$sub"}; + eval "sub ${package}::$sub ".($proto ? "($proto)" : '') . ' { Carp::confess("local '.$sub.'") }; 1' + or die $@; + } + } +} + +{ + package Foo; + use Moo; + sub welp { 1 } +} + +{ + package WithOverridden; + use AddOverrides; + use Moo; + + sub BUILD { 1 } + sub DEMOLISH { CORE::die "demolish\n" if $::FATAL_DEMOLISH } + around BUILDARGS => sub { + my $orig = CORE::shift(); + my $self = CORE::shift(); + $self->$orig(@_); + }; + + has attr1 => (is => 'ro', required => 1, handles => ['welp']); + has attr2 => (is => 'ro', default => CORE::undef()); + has attr3 => (is => 'rw', isa => sub { CORE::die "nope" } ); +} + +unlike exception { WithOverridden->new(1) }, qr/local/, + 'bad constructor arguments error ignores local functions'; +unlike exception { WithOverridden->new }, qr/local/, + 'missing attributes error ignores local functions'; +unlike exception { WithOverridden->new(attr1 => 1, attr3 => 1) }, qr/local/, + 'constructor isa checks ignores local functions'; +my $o; +is exception { $o = WithOverridden->new(attr1 => Foo->new) }, undef, + 'constructor without error ignores local functions'; +unlike exception { $o->attr3(1) }, qr/local/, + 'isa checks ignores local functions'; +is exception { $o->welp }, undef, + 'delegates ignores local functions'; + +{ + no warnings FATAL => 'all'; + use warnings 'all'; + my $w = ''; + local $SIG{__WARN__} = sub { $w .= $_[0] }; + local $::FATAL_DEMOLISH = 1; + undef $o; + unlike $w, qr/local/, + 'destroy ignores local functions'; +} + +done_testing; diff --git a/t/perl-56-like.t b/t/perl-56-like.t new file mode 100644 index 0000000..4ffee23 --- /dev/null +++ b/t/perl-56-like.t @@ -0,0 +1,16 @@ +use B (); +BEGIN { delete $B::{perlstring} }; +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MyClass; + use Moo; + my $string = join('', "\x00" .. "\x7F"); + has foo => (is => 'ro', default => $string); + ::is +__PACKAGE__->new->foo, $string, + "can quote arbitrary strings 5.6 style"; +} + +done_testing; diff --git a/t/strictures.t b/t/strictures.t new file mode 100644 index 0000000..d8e83fe --- /dev/null +++ b/t/strictures.t @@ -0,0 +1,36 @@ +BEGIN { delete $ENV{MOO_FATAL_WARNINGS} } +use strict; +use warnings; +use Test::More; + +$INC{'strictures.pm'} = __FILE__; +my $strictures = 0; +my $version; +sub strictures::VERSION { + $version = $_[1]; + 2;; +} +sub strictures::import { + $strictures++; + strict->import; + warnings->import(FATAL => 'all'); +} + +local $SIG{__WARN__} = sub {}; +eval q{ + use Moo::_strictures; + 0 + "string"; +}; +is $strictures, 0, 'strictures not imported without MOO_FATAL_WARNINGS'; +is $@, '', 'warnings not fatal without MOO_FATAL_WARNINGS'; + +$ENV{MOO_FATAL_WARNINGS} = 1; +eval q{ + use Moo::_strictures; + 0 + "string"; +}; +is $strictures, 1, 'strictures imported with MOO_FATAL_WARNINGS'; +is $version, 2, 'strictures version 2 requested with MOO_FATAL_WARNINGS'; +like $@, qr/isn't numeric/, 'warnings fatal with MOO_FATAL_WARNINGS'; + +done_testing; diff --git a/t/sub-and-handles.t b/t/sub-and-handles.t new file mode 100644 index 0000000..95efdf6 --- /dev/null +++ b/t/sub-and-handles.t @@ -0,0 +1,84 @@ +use Moo::_strictures; +use Test::More; + +{ + package DelegateBar; + + use Moo; + + sub bar { 'unextended!' } + + package Does::DelegateToBar; + + use Moo::Role; + + has _barrer => ( + is => 'ro', + default => sub { DelegateBar->new }, + handles => { _bar => 'bar' }, + ); + + sub get_barrer { $_[0]->_barrer } + + package ConsumesDelegateToBar; + + use Moo; + + with 'Does::DelegateToBar'; + + has bong => ( is => 'ro' ); + + package Does::OverrideDelegate; + + use Moo::Role; + + sub _bar { 'extended' } + + package First; + + use Moo; + extends 'ConsumesDelegateToBar'; + with 'Does::OverrideDelegate'; + + has '+_barrer' => ( is => 'rw' ); + + package Second; + + use Moo; + extends 'ConsumesDelegateToBar'; + + sub _bar { 'extended' } + + has '+_barrer' => ( is => 'rw' ); + + package Fourth; + + use Moo; + extends 'ConsumesDelegateToBar'; + + sub _bar { 'extended' } + + has '+_barrer' => ( + is => 'rw', + handles => { _baz => 'bar' }, + ); + package Third; + + use Moo; + extends 'ConsumesDelegateToBar'; + with 'Does::OverrideDelegate'; + + has '+_barrer' => ( + is => 'rw', + handles => { _baz => 'bar' }, + ); +} + +is(First->new->_bar, 'extended', 'overriding delegate method with role works'); +is(Fourth->new->_bar, 'extended', '... even when you specify other delegates in subclass'); +is(Fourth->new->_baz, 'unextended!', '... and said other delegate still works'); +is(Second->new->_bar, 'extended', 'overriding delegate method directly works'); +is(Third->new->_bar, 'extended', '... even when you specify other delegates in subclass'); +is(Third->new->_baz, 'unextended!', '... and said other delegate still works'); + +done_testing; diff --git a/t/subconstructor.t b/t/subconstructor.t new file mode 100644 index 0000000..eb18ede --- /dev/null +++ b/t/subconstructor.t @@ -0,0 +1,18 @@ +use Moo::_strictures; +use Test::More; + +{ + package SubCon1; + + use Moo; + + has foo => (is => 'ro'); + + package SubCon2; + + our @ISA = qw(SubCon1); +} + +ok(SubCon2->new, 'constructor completes'); + +done_testing; diff --git a/t/undef-bug.t b/t/undef-bug.t new file mode 100644 index 0000000..c3ed934 --- /dev/null +++ b/t/undef-bug.t @@ -0,0 +1,13 @@ +use Test::More tests => 1; + +package Foo; +use Moo; + +has this => (is => 'ro'); + +package main; + +my $foo = Foo->new; + +ok not(exists($foo->{this})), + "new objects don't have undef attributes"; diff --git a/t/use-after-no.t b/t/use-after-no.t new file mode 100644 index 0000000..e59b7da --- /dev/null +++ b/t/use-after-no.t @@ -0,0 +1,40 @@ +use Moo::_strictures; +use Test::More; + +ok eval q{ + package Spoon; + use Moo; + + has foo => ( is => 'ro' ); + + no Moo; + + use Moo; + + has foo2 => ( is => 'ro' ); + + no Moo; + + 1; +}, "subs imported on 'use Moo;' after 'no Moo;'" + or diag $@; + +ok eval q{ + package Roller; + use Moo::Role; + + has foo => ( is => 'ro' ); + + no Moo::Role; + + use Moo::Role; + + has foo2 => ( is => 'ro' ); + + no Moo::Role; + + 1; +}, "subs imported on 'use Moo::Role;' after 'no Moo::Role;'" + or diag $@; + +done_testing; diff --git a/t/zzz-check-breaks.t b/t/zzz-check-breaks.t new file mode 100644 index 0000000..36a8fce --- /dev/null +++ b/t/zzz-check-breaks.t @@ -0,0 +1,49 @@ +use strict; +use warnings; +use Test::More; + +my $meta_file; +BEGIN { + eval { require CPAN::Meta } + or plan skip_all => 'CPAN::Meta required for checking breakages'; + eval { require CPAN::Meta::Requirements } + or plan skip_all => 'CPAN::Meta::Requirements required for checking breakages'; + ($meta_file) = grep -f, qw(MYMETA.json MYMETA.yml META.json META.yml) + or plan skip_all => 'no META file exists'; +} + +use ExtUtils::MakeMaker; +use Module::Runtime qw(module_notional_filename); + +my $meta = CPAN::Meta->load_file($meta_file)->as_struct; +my $req = CPAN::Meta::Requirements->from_string_hash( $meta->{x_breaks} ); + +pass 'checking breakages...'; + +my @breaks; +for my $module ($req->required_modules) { + my ($pm_file) = grep -e, map $_.'/'.module_notional_filename($module), @INC; + next + unless $pm_file; + my $version = MM->parse_version($pm_file); + next + unless defined $version; + (my $check_version = $version) =~ s/_//; + if ($req->accepts_module($module, $version)) { + my $broken_v = $req->requirements_for_module($module); + $broken_v = ">= $broken_v" + unless $broken_v =~ /\A\s*(?:==|>=|>|<=|<|!=)/; + push @breaks, [$module, $check_version, $broken_v]; + } +} + +if (@breaks) { + diag "Installing Moo $meta->{version} will break these modules:\n\n" + . (join '', map { + "$_->[0] (found version $_->[1])\n" + . " Broken versions: $_->[2]\n" + } @breaks) + . "\nYou should now update these modules!"; +} + +done_testing; diff --git a/xt/bless-override.t b/xt/bless-override.t new file mode 100644 index 0000000..50e120c --- /dev/null +++ b/xt/bless-override.t @@ -0,0 +1,21 @@ +use Moo::_strictures; +BEGIN { + *CORE::GLOBAL::bless = sub { + my $obj = CORE::bless( $_[0], (@_ > 1) ? $_[1] : CORE::caller() ); + + $obj->isa("Foo"); + + $obj; + }; +} +use Test::More; +use Test::Fatal; + +use Moose (); + +is exception { + package SomeClass; + use Moo; +}, undef, "isa call in bless override doesn't break Moo+Moose"; + +done_testing; diff --git a/xt/class-tiny.t b/xt/class-tiny.t new file mode 100644 index 0000000..c5c88f1 --- /dev/null +++ b/xt/class-tiny.t @@ -0,0 +1,28 @@ +use Moo::_strictures; +use Test::More; +use Class::Tiny 1.001; + +my %build; + +{ + package MyClass; + use Class::Tiny qw(name); + sub BUILD { + $build{+__PACKAGE__}++; + } +} +{ + package MySubClass; + use Moo; + extends 'MyClass'; + sub BUILD { + $build{+__PACKAGE__}++; + } + has 'attr1' => (is => 'ro'); +} +MySubClass->new; + +is $build{MyClass}, 1; +is $build{MySubClass}, 1; + +done_testing; diff --git a/xt/croak-locations.t b/xt/croak-locations.t new file mode 100644 index 0000000..9bd9186 --- /dev/null +++ b/xt/croak-locations.t @@ -0,0 +1,40 @@ +use Moo::_strictures; +use Test::More; +use lib 't/lib'; +use ErrorLocation; + +use Moo::HandleMoose; + +location_ok <<'END_CODE', 'Moo::sification::unimport - Moo::HandleMoose enabled'; +use Moo::sification (); +Moo::sification->unimport; +END_CODE + +location_ok <<'END_CODE', 'Moo::HandleMoose::inject_real_metaclass_for - Bad %TYPE_MAP value'; +use Moo; +use Moo::HandleMoose (); +my $isa = sub { die "bad value" }; +$Moo::HandleMoose::TYPE_MAP{$isa} = sub { return 1 }; +has attr => (is => 'ro', isa => $isa); +$PACKAGE->meta->name; +END_CODE + +{ + local $TODO = "croaks in roles don't skip consuming class"; +location_ok <<'END_CODE', 'Moo::Role::_inhale_if_moose - isa from type'; +BEGIN { + eval qq{ + package ${PACKAGE}::Role; + use Moose::Role; + has attr1 => (is => 'ro', isa => 'HashRef'); + 1; + } or die $@; +} +use Moo; +with "${PACKAGE}::Role"; +package Elsewhere; +$PACKAGE->new(attr1 => []); +END_CODE +} + +done_testing; diff --git a/xt/fakemetaclass.t b/xt/fakemetaclass.t new file mode 100644 index 0000000..61fa003 --- /dev/null +++ b/xt/fakemetaclass.t @@ -0,0 +1,36 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Moo::HandleMoose::FakeMetaClass; + +sub Foo::bar { 'bar' } + +my $fake = bless { name => 'Foo' }, 'Moo::HandleMoose::FakeMetaClass'; + +my $bar = $fake->get_method('bar'); +is $bar->body, \&Foo::bar, + 'able to call moose meta methods'; + +my $fm = 'Moo::HandleMoose::FakeMetaClass'; + +is exception { + my $can = $fm->can('can'); + is $can, \&Moo::HandleMoose::FakeMetaClass::can, + 'can usable as class method'; + + ok $fm->isa($fm), + 'isa usable as class method'; + + local $Moo::HandleMoose::FakeMetaClass::VERSION = 5; + is $fm->VERSION, 5, + 'VERSION usable as class method'; +}, undef, + 'no errors calling isa, can, or VERSION'; + +like exception { + $fm->missing_method; +}, qr/Can't call missing_method without object instance/, + 'nonexistent methods give correct error when called on class'; + +done_testing; diff --git a/xt/global-destruct-jenga-helper.pl b/xt/global-destruct-jenga-helper.pl new file mode 100644 index 0000000..c32f035 --- /dev/null +++ b/xt/global-destruct-jenga-helper.pl @@ -0,0 +1,17 @@ +use Moo::_strictures; +{ + package BaseClass; + use Moo; +} +{ + package Subclass; + use Moose; + extends 'BaseClass'; + __PACKAGE__->meta->make_immutable; +} +{ + package Blorp; + use Moo; + extends 'Subclass'; +} +our $o = Blorp->new; diff --git a/xt/global-destruct-jenga.t b/xt/global-destruct-jenga.t new file mode 100644 index 0000000..310b56b --- /dev/null +++ b/xt/global-destruct-jenga.t @@ -0,0 +1,19 @@ +use Moo::_strictures; +use Test::More; +use IPC::Open3; +use File::Basename qw(dirname); + +delete $ENV{PERL5LIB}; +delete $ENV{PERL5OPT}; +my $pid = open3 my $in, my $fh, undef, $^X, (map "-I$_", @INC), dirname(__FILE__).'/global-destruct-jenga-helper.pl' + or die "can run jenga helper: $!"; +my $out = do { local $/; <$fh> }; +close $out; +close $in; +waitpid $pid, 0; +my $err = $?; + +is $out, '', 'no error output from global destruct of jenga object'; +is $err, 0, 'process ended successfully'; + +done_testing; diff --git a/xt/handle_moose.t b/xt/handle_moose.t new file mode 100644 index 0000000..7eb5b9c --- /dev/null +++ b/xt/handle_moose.t @@ -0,0 +1,115 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; +use Sub::Quote qw(quote_sub); + +{ + package Foo; + + use Moo; + + has one => (is => 'ro'); + has two => (is => 'rw', init_arg => undef); + has three => (is => 'ro', init_arg => 'THREE', required => 1); + + package Bar; + + use Moo::Role; + + has four => (is => 'ro'); + ::quote_sub 'Bar::quoted' => '1'; + + package Baz; + + use Moo; + + extends 'Foo'; + + with 'Bar'; + + has five => (is => 'rw'); +} + +require Moose; + +my $meta = Class::MOP::get_metaclass_by_name('Foo'); + +my $attr; + +ok($attr = $meta->get_attribute('one'), 'Meta-attribute exists'); +is($attr->get_read_method, 'one', 'Method name'); +is($attr->get_read_method_ref->body, Foo->can('one'), 'Right method'); + +is(Foo->new(one => 1, THREE => 3)->one, 1, 'Accessor still works'); + +is( + Foo->meta->get_attribute('one')->get_read_method, 'one', + 'Method name via ->meta' +); + +$meta = Moose::Meta::Class->initialize('Spoon'); + +$meta->superclasses('Moose::Object'); + +Moose::Util::apply_all_roles($meta, 'Bar'); + +my $spoon = Spoon->new(four => 4); + +is($spoon->four, 4, 'Role application ok'); + +{ + package MooRequiresFour; + + use Moo::Role; + + requires 'four'; + + package MooRequiresGunDog; + + use Moo::Role; + + requires 'gun_dog'; +} + +is exception { + Moose::Util::apply_all_roles($meta, 'MooRequiresFour'); +}, undef, 'apply role with satisified requirement'; + +ok exception { + Moose::Util::apply_all_roles($meta, 'MooRequiresGunDog'); +}, 'apply role with unsatisified requirement'; + +{ + package WithNonMethods; + use Scalar::Util qw(looks_like_number); + use Moo; + + my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__); + ::ok(!$meta->has_method('looks_like_number'), + 'imported sub before use Moo not included in inflated metaclass'); +} + +{ + package AnotherMooseRole; + use Moose::Role; + has attr1 => (is => 'ro'); +} + +ok(Moo::Role->is_role('AnotherMooseRole'), + 'Moose roles are Moo::Role->is_role'); + +{ + { + package AMooClass; + use Moo; + } + { + package AMooRole; + use Moo::Role; + } + my $c = Moo::Role->create_class_with_roles('AMooClass', 'AMooRole'); + my $meta = Class::MOP::get_metaclass_by_name($c); + ok $meta, 'generated class via create_class_with_roles has metaclass'; +} + +done_testing; diff --git a/xt/has-after-meta.t b/xt/has-after-meta.t new file mode 100644 index 0000000..f37983c --- /dev/null +++ b/xt/has-after-meta.t @@ -0,0 +1,25 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Moose (); + +{ + package MyClass; + use Moo; + + has attr1 => ( is => 'ro' ); + + # this will inflate a metaclass and undefer all of the methods, including the + # constructor. the constructor still needs to be modifyable though. + # Metaclass inflation can happen for unexpected reasons, such as using + # namespace::autoclean (but only if Moose has been loaded). + __PACKAGE__->meta->name; + + ::is ::exception { + has attr2 => ( is => 'ro' ); + }, undef, + 'attributes can be added after metaclass inflation'; +} + +done_testing; diff --git a/xt/implicit-moose-types.t b/xt/implicit-moose-types.t new file mode 100644 index 0000000..34e209c --- /dev/null +++ b/xt/implicit-moose-types.t @@ -0,0 +1,32 @@ +use Moo::_strictures; +use Test::More; + +use Moose::Util::TypeConstraints qw(find_type_constraint); + +{ + package TestRole; + use Moo::Role; +} + +{ + package TestClass; + use Moo; + + with 'TestRole'; +} + +my $o = TestClass->new; + +foreach my $name (qw(TestClass TestRole)) { + ok !find_type_constraint($name), "No $name constraint created without Moose loaded"; +} +note "Loading Moose"; +require Moose; + +foreach my $name (qw(TestClass TestRole)) { + my $tc = find_type_constraint($name); + isa_ok $tc, 'Moose::Meta::TypeConstraint', "$name constraint" + and ok $tc->check($o), "TestClass object passes $name constraint"; +} + +done_testing; diff --git a/xt/inflate-our-classes.t b/xt/inflate-our-classes.t new file mode 100644 index 0000000..c608b6f --- /dev/null +++ b/xt/inflate-our-classes.t @@ -0,0 +1,25 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Moo::HandleMoose; +use Module::Runtime qw(use_module); + +foreach my $class (qw( + Method::Generate::Accessor + Method::Generate::Constructor + Method::Generate::BuildAll + Method::Generate::DemolishAll +)) { + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, $_[0] }; + + is exception { + Moo::HandleMoose::inject_real_metaclass_for(use_module($class)) + }, undef, + "No exceptions inflating $class"; + ok !@warnings, "No warnings inflating $class" + or diag "Got warnings: @warnings"; +} + +done_testing; diff --git a/xt/inflate-undefer.t b/xt/inflate-undefer.t new file mode 100644 index 0000000..3452485 --- /dev/null +++ b/xt/inflate-undefer.t @@ -0,0 +1,22 @@ +use Moo::_strictures; +use Test::More; + +use Moose (); + +{ + package MyClass; + use Moo; + use Sub::Defer qw(defer_sub); + + my $undeferred; + my $deferred = defer_sub +__PACKAGE__.'::welp' => sub { + $undeferred = sub { 1 }; + }; + + __PACKAGE__->meta->name; + + ::ok +$undeferred, "meta inflation undefers subs"; + ::is +__PACKAGE__->can('welp'), $undeferred, "undeferred sub installed"; +} + +done_testing; diff --git a/xt/jenga.t b/xt/jenga.t new file mode 100644 index 0000000..29c6cd8 --- /dev/null +++ b/xt/jenga.t @@ -0,0 +1,48 @@ +use Moo::_strictures; +use Test::More; + +{ + package Tower1; + + use Moo; + + has 'attr1' => (is => 'ro', required => 1); + + package Tower2; + + use Moose; + + extends 'Tower1'; + + has 'attr2' => (is => 'ro', required => 1); + + __PACKAGE__->meta->make_immutable; + + package Tower3; + + use Moo; + + extends 'Tower2'; + + has 'attr3' => (is => 'ro', required => 1); + + package Tower4; + + use Moose; + + extends 'Tower3'; + + has 'attr4' => (is => 'ro', required => 1); + + __PACKAGE__->meta->make_immutable; +} + +foreach my $num (1..4) { + my $class = "Tower${num}"; + my @attrs = map "attr$_", 1..$num; + my %args = map +($_ => "${_}_value"), @attrs; + my $obj = $class->new(%args); + is($obj->{$_}, "${_}_value", "Attribute $_ ok for $class") for @attrs; +} + +done_testing; diff --git a/xt/moo-attr-handles-moose-role.t b/xt/moo-attr-handles-moose-role.t new file mode 100644 index 0000000..36cfa25 --- /dev/null +++ b/xt/moo-attr-handles-moose-role.t @@ -0,0 +1,34 @@ +use Moo::_strictures; + +use Test::More; + +{ + package MooseRole; + use Moose::Role; + + sub warble { "warble" } + $INC{"MooseRole.pm"} = __FILE__; +} + +{ + package MooseClass; + use Moose; + with 'MooseRole'; +} + +{ + package MooClass; + use Moo; + + has attr => ( + is => 'ro', + handles => 'MooseRole', + ); +} + +my $o = MooClass->new(attr => MooseClass->new); +isa_ok( $o, 'MooClass' ); +can_ok( $o, 'warble' ); +is( $o->warble, "warble", 'Delegated method called correctly' ); + +done_testing; diff --git a/xt/moo-consume-moose-role-coerce.t b/xt/moo-consume-moose-role-coerce.t new file mode 100644 index 0000000..ea6b580 --- /dev/null +++ b/xt/moo-consume-moose-role-coerce.t @@ -0,0 +1,29 @@ +use Moo::_strictures; +use Test::More; + +{ + package RoleOne; + use Moose::Role; + use Moose::Util::TypeConstraints; + + subtype 'Foo', as 'Int'; + coerce 'Foo', from 'Str', via { 3 }; + + has foo => ( + is => 'rw', + isa => 'Foo', + coerce => 1, + clearer => '_clear_foo', + ); +} +{ + package Class; + use Moo; # Works if use Moose.. + + with 'RoleOne'; +} + +my $i = Class->new( foo => 'bar' ); +is $i->foo, 3, 'coerce from type works'; + +done_testing; diff --git a/xt/moo-consume-moose-role-multiple.t b/xt/moo-consume-moose-role-multiple.t new file mode 100644 index 0000000..e708cb4 --- /dev/null +++ b/xt/moo-consume-moose-role-multiple.t @@ -0,0 +1,29 @@ +use Moo::_strictures; +use Test::More; + +{ + package RoleOne; + use Moose::Role; + + has foo => ( is => 'rw' ); +} + +{ + package RoleTwo; + use Moose::Role; + + has bar => ( is => 'rw' ); +} + +{ + package SomeClass; + use Moo; + + with 'RoleOne', 'RoleTwo'; +} + +my $i = SomeClass->new( foo => 'bar', bar => 'baz' ); +is $i->foo, 'bar', "attribute from first role is correct"; +is $i->bar, 'baz', "attribute from second role is correct"; + +done_testing; diff --git a/xt/moo-consume-mouse-role-coerce.t b/xt/moo-consume-mouse-role-coerce.t new file mode 100644 index 0000000..5cf212f --- /dev/null +++ b/xt/moo-consume-mouse-role-coerce.t @@ -0,0 +1,31 @@ +use Moo::_strictures; +use Test::More "$]" < 5.008009 + ? (skip_all => 'Mouse is broken on perl <= 5.8.8') + : (); + +{ + package RoleOne; + use Mouse::Role; + use Mouse::Util::TypeConstraints; + + subtype 'Foo', as 'Int'; + coerce 'Foo', from 'Str', via { 3 }; + + has foo => ( + is => 'rw', + isa => 'Foo', + coerce => 1, + clearer => '_clear_foo', + ); +} +{ + package Class; + use Moo; # Works if use Moose.. + + with 'RoleOne'; +} + +my $i = Class->new( foo => 'bar' ); +is $i->foo, 3, 'coerce from type works'; + +done_testing; diff --git a/xt/moo-does-moose-role.t b/xt/moo-does-moose-role.t new file mode 100644 index 0000000..3a26acd --- /dev/null +++ b/xt/moo-does-moose-role.t @@ -0,0 +1,242 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package Ker; + + use Moo::Role; + + sub has_ker {} +} + +BEGIN { + package Splat; + + use Moose::Role; + + requires 'monkey'; + + sub punch { 1 } + + sub jab { 0 } + + around monkey => sub { 'OW' }; + + has trap => (is => 'ro', default => sub { -1 }); + + sub has_splat {} +} + +BEGIN { + package KerSplat; + use Moo::Role; + + with qw/ + Ker + Splat + /; +} + +BEGIN { + package Splattered; + + use Moo; + + sub monkey { 'WHAT' } + + with 'Splat'; + + sub jab { 3 } +} + +BEGIN { + package Ker::Splattered; + + use Moo; + + sub monkey { 'WHAT' } + + with qw/ Ker Splat /; + + sub jab { 3 } +} + +BEGIN { + package KerSplattered; + + use Moo; + + sub monkey { 'WHAT' } + + with qw/ KerSplat /; + + sub jab { 3 } +} + +BEGIN { + package Plunk; + + use Moo::Role; + + has pp => (is => 'rw', moosify => sub { + my $spec = shift; + $spec->{documentation} = 'moosify'; + }); +} + +BEGIN { + package Plank; + + use Moo; + use Sub::Quote; + + has vv => (is => 'rw', moosify => [quote_sub(q| + $_[0]->{documentation} = 'moosify'; + |), sub { $_[0]->{documentation} = $_[0]->{documentation}.' foo'; }]); +} + +BEGIN { + package Plunker; + + use Moose; + + with 'Plunk'; +} + +BEGIN { + package Planker; + + use Moose; + + extends 'Plank'; +} + +BEGIN { + package Plonk; + use Moo; + has kk => (is => 'rw', moosify => [sub { + $_[0]->{documentation} = 'parent'; + }]); +} +BEGIN { + package Plonker; + use Moo; + extends 'Plonk'; + has '+kk' => (moosify => sub { + my $spec = shift; + $spec->{documentation} .= 'child'; + }); +} +BEGIN{ + local $SIG{__WARN__} = sub { fail "warning: $_[0]" }; + package SplatteredMoose; + use Moose; + extends 'Splattered'; +} + +foreach my $s ( + Splattered->new, + Ker::Splattered->new, + KerSplattered->new, + SplatteredMoose->new +) { + can_ok($s, 'punch') + and is($s->punch, 1, 'punch'); + can_ok($s, 'jab') + and is($s->jab, 3, 'jab'); + can_ok($s, 'monkey') + and is($s->monkey, 'OW', 'monkey'); + can_ok($s, 'trap') + and is($s->trap, -1, 'trap'); +} + +foreach my $c (qw/ + Ker::Splattered + KerSplattered +/) { + can_ok($c, 'has_ker'); + can_ok($c, 'has_splat'); +} + +is(Plunker->meta->find_attribute_by_name('pp')->documentation, 'moosify', 'moosify modifies attr specs'); +is(Planker->meta->find_attribute_by_name('vv')->documentation, 'moosify foo', 'moosify modifies attr specs as array'); + +is( Plonker->meta->find_attribute_by_name('kk')->documentation, + 'parentchild', + 'moosify applies for overridden attributes with roles'); + +{ + package MooseAttrTrait; + use Moose::Role; + + has 'extra_attr' => (is => 'ro'); + has 'extra_attr_noinit' => (is => 'ro', init_arg => undef); +} + +{ + local $SIG{__WARN__} = sub { fail "warning: $_[0]" }; + package UsingMooseTrait; + use Moo; + + has one => ( + is => 'ro', + traits => ['MooseAttrTrait'], + extra_attr => 'one', + extra_attr_noinit => 'two', + ); +} + +ok( UsingMooseTrait->meta + ->find_attribute_by_name('one')->can('extra_attr'), + 'trait was properly applied'); +is( UsingMooseTrait->meta->find_attribute_by_name('one') + ->extra_attr, + 'one', + 'trait attributes maintain values'); + +{ + package NeedTrap; + use Moo::Role; + + requires 'trap'; +} + +is exception { + package Splattrap; + use Moo; + sub monkey {} + + with qw(Splat NeedTrap); +}, undef, 'requires satisfied by Moose attribute composed at the same time'; + +{ + package HasMonkey; + use Moo; + sub monkey {} +} +is exception { + Moo::Role->create_class_with_roles('HasMonkey', 'Splat', 'NeedTrap'); +}, undef, ' ... and when created by create_class_with_roles'; + +{ + package FishRole; + use Moose::Role; + + has fish => (is => 'ro', isa => 'Plunker'); +} +{ + package FishClass; + use Moo; + with 'FishRole'; +} + +is exception { + FishClass->new(fish => Plunker->new); +}, undef, 'inhaling attr with isa works'; + +like exception { + FishClass->new(fish => 4); +}, qr/Type constraint failed/, ' ... and isa check works'; + +done_testing; diff --git a/xt/moo-does-mouse-role.t b/xt/moo-does-mouse-role.t new file mode 100644 index 0000000..4bebc5e --- /dev/null +++ b/xt/moo-does-mouse-role.t @@ -0,0 +1,102 @@ +use Moo::_strictures; +use Test::More "$]" < 5.008009 + ? (skip_all => 'Mouse is broken on perl <= 5.8.8') + : (); +use Test::Fatal; + +BEGIN { + package Ker; + + use Moo::Role; + + sub has_ker {} +} + +BEGIN { + package Splat2; + + use Mouse::Role; + + requires 'monkey'; + + sub punch { 1 } + + sub jab { 0 } + + around monkey => sub { 'OW' }; + + has trap => (is => 'ro', default => sub { -1 }); + + sub has_splat {} +} + +BEGIN { + package KerSplat2; + use Moo::Role; + + with qw(Ker Splat2); +} + +BEGIN { + package KerSplattered2; + + use Moo; + + sub monkey { 'WHAT' } + + with qw(KerSplat2); + + sub jab { 3 } +} + +BEGIN { + package Splattered2; + + use Moo; + + sub monkey { 'WHAT' } + + with qw(Splat2); + + sub jab { 3 } +} + +BEGIN { + package Ker::Splattered2; + + use Moo; + + sub monkey { 'WHAT' } + + with qw(Ker Splat2); + + sub jab { 3 } +} + +foreach my $s ( + Splattered2->new, + Ker::Splattered2->new, + KerSplattered2->new, +) { + can_ok($s, 'punch') + and is($s->punch, 1, 'punch'); + can_ok($s, 'jab') + and is($s->jab, 3, 'jab'); + can_ok($s, 'monkey') + and is($s->monkey, 'OW', 'monkey'); + can_ok($s, 'trap') + and is($s->trap, -1, 'trap'); +} + +foreach my $c (qw/ + Ker::Splattered2 + KerSplattered2 +/) { + can_ok($c, 'has_ker'); + can_ok($c, 'has_splat'); +} + +is ref Splattered2->meta, 'Moo::HandleMoose::FakeMetaClass', + 'Mouse::Role meta method not copied'; + +done_testing; diff --git a/xt/moo-extend-moose.t b/xt/moo-extend-moose.t new file mode 100644 index 0000000..5500275 --- /dev/null +++ b/xt/moo-extend-moose.t @@ -0,0 +1,46 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package MooseRole; + use Moose::Role; + has attr_from_role => ( is => 'ro' ); +} + +BEGIN { + package MooseParent; + use Moose; + with 'MooseRole'; + has attr_from_parent => ( is => 'ro' ), +} + +BEGIN { + package MooRole; + use Moo::Role; + has attr_from_role2 => ( is => 'ro' ); +} + +BEGIN { + package MooChild; + use Moo; + extends 'MooseParent'; + with 'MooRole'; + has attr_from_child => ( is => 'ro' ); +} + +my $o = MooChild->new( + attr_from_role => 1, + attr_from_parent => 2, + attr_from_role2 => 3, + attr_from_child => 4, +); +is $o->attr_from_role, 1; +is $o->attr_from_parent, 2; +is $o->attr_from_role2, 3; +is $o->attr_from_child, 4; + +ok +MooChild->meta->does_role('MooseRole'); +ok +MooChild->does('MooseRole'); + +done_testing; diff --git a/xt/moo-inflate.t b/xt/moo-inflate.t new file mode 100644 index 0000000..8bd93f9 --- /dev/null +++ b/xt/moo-inflate.t @@ -0,0 +1,18 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MooClass; + use Moo; +} +use Moose (); +use Moo::Role (); + +ok !$Moo::HandleMoose::DID_INJECT{'MooClass'}, + "No metaclass generated for Moo class on initial Moose load"; +Moo::Role->is_role('MooClass'); +ok !$Moo::HandleMoose::DID_INJECT{'MooClass'}, + "No metaclass generated for Moo class after testing with ->is_role"; + +done_testing; diff --git a/xt/moo-object-meta-can.t b/xt/moo-object-meta-can.t new file mode 100644 index 0000000..18bd6a0 --- /dev/null +++ b/xt/moo-object-meta-can.t @@ -0,0 +1,47 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; +use Moo::Object; + +# See RT#84615 + +ok( Moo::Object->can('meta'), 'Moo::Object can meta'); +is( exception { Moo::Object->meta->can('can') } , undef, "Moo::Object->meta->can doesn't explode" ); + +{ + package Example; + use base 'Moo::Object'; + +} + +ok( Example->can('meta'), 'Example can meta'); +is( exception { Example->meta->can('can') } , undef, "Example->meta->can doesn't explode" ); + +# Haarg++ noting that previously, this *also* would have died due to its absence from %Moo::Makers; +{ + package Example_2; + use Moo; + + has 'attr' => ( is => ro =>, ); + + $INC{'Example_2.pm'} = 1; +} +{ + package Example_3; + use base "Example_2"; +} + +ok( Example_2->can('meta'), 'Example_2 can meta') and do { + return unless ok( Example_2->meta->can('get_all_attributes'), 'Example_2 meta can get_all_attributes' ); + my (@attributes) = Example_2->meta->get_all_attributes; + is( scalar @attributes, 1, 'Has one attribute' ); +}; + +ok( Example_3->can('meta'), 'Example_3 can meta') and do { + return unless is( exception { Example_3->meta->can('can') } , undef, "Example_3->meta->can doesn't explode" ); + return unless ok( Example_3->meta->can('get_all_attributes'), 'Example_3 meta can get_all_attributes' ); + my (@attributes) = Example_3->meta->get_all_attributes; + is( scalar @attributes, 1, 'Has one attribute' ); +}; + +done_testing; diff --git a/xt/moo-role-types.t b/xt/moo-role-types.t new file mode 100644 index 0000000..0ef2dfc --- /dev/null +++ b/xt/moo-role-types.t @@ -0,0 +1,70 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package TestClientClass; + use Moo; + + sub consume {} +} + +{ + package TestBadClientClass; + use Moo; + + sub not_consume {} +} + +{ + package TestRole; + use Moo::Role; + use Sub::Quote; + + has output_to => ( + isa => quote_sub(q{ + use Scalar::Util (); + die $_[0] . "Does not have a ->consume method" unless Scalar::Util::blessed($_[0]) && $_[0]->can('consume'); }), + is => 'ro', + required => 1, + coerce => quote_sub(q{ + use Scalar::Util (); + if (Scalar::Util::blessed($_[0]) && $_[0]->can('consume')) { + $_[0]; + } else { + my %stuff = %{$_[0]}; + my $class = delete($stuff{class}); + $class->new(%stuff); + } + }), + ); +} + +{ + package TestMooClass; + use Moo; + + with 'TestRole'; +} + +{ + package TestMooseClass; + use Moose; + + with 'TestRole'; +} + +foreach my $name (qw/ TestMooClass TestMooseClass /) { + my $i = $name->new(output_to => TestClientClass->new()); + ok $i->output_to->can('consume'); + $i = $name->new(output_to => { class => 'TestClientClass' }); + ok $i->output_to->can('consume'); +}; + +foreach my $name (qw/ TestMooClass TestMooseClass /) { + ok !exception { TestBadClientClass->new }; + ok exception { $name->new(output_to => TestBadClientClass->new()) }; + ok exception { $name->new(output_to => { class => 'TestBadClientClass' }) }; +} + +done_testing; diff --git a/xt/moo-roles-into-moose-class-attr-override-with-autoclean.t b/xt/moo-roles-into-moose-class-attr-override-with-autoclean.t new file mode 100644 index 0000000..386cde2 --- /dev/null +++ b/xt/moo-roles-into-moose-class-attr-override-with-autoclean.t @@ -0,0 +1,38 @@ +use Moo::_strictures; +use Test::More; +use lib "t/lib"; +use InlineModule ( + MooRoleWithAttrWithAutoclean => q{ + package MooRoleWithAttrWithAutoclean; + use Moo::Role; + # Note that autoclean here is the key bit! + # It causes the metaclass to be loaded and used before the 'has' fires + # so Moo needs to blow it away again at that point so the attribute gets + # added + use namespace::autoclean; + + has output_to => ( + is => 'ro', + required => 1, + ); + + 1; + }, +); + +{ + package Bax; + use Moose; + + with qw/ + MooRoleWithAttrWithAutoclean + /; + + + has '+output_to' => ( + required => 1, + ); +} + +pass 'classes and roles built without error'; +done_testing; diff --git a/xt/moo-roles-into-moose-class.t b/xt/moo-roles-into-moose-class.t new file mode 100644 index 0000000..6aa2eaf --- /dev/null +++ b/xt/moo-roles-into-moose-class.t @@ -0,0 +1,77 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moo::Role; + # if we autoclean here there's nothing left and then load_class tries + # to require Foo during Moose application and everything breaks. +} +{ + package Bar; + use Moo::Role; + use namespace::autoclean; + + has attr => ( + is => 'ro' + ); + + sub thing {} +} +{ + package Baz; + use Moose; + no Moose; + + ::ok(!__PACKAGE__->can('has'), 'No has function after no Moose;'); + Moose::with('Baz', 'Bar'); +} + +::is(Baz->can('thing'), Bar->can('thing'), 'Role copies method correctly'); +::ok(Baz->can('attr'), 'Attr accessor correct'); +::ok(!Bar->can('has'), 'Moo::Role sugar removed by autoclean'); +::ok(!Bar->can('with'), 'Role::Tiny sugar removed by autoclean'); +::ok(!Baz->can('has'), 'Sugar not copied'); + +{ + package Bax; + use Moose; + with qw/ + Foo + Bar + /; +} + +{ + package Baw; + use Moo::Role; + has attr => ( + is => 'ro', + traits => ['Array'], + default => sub { [] }, + handles => { + push_attr => 'push', + }, + ); +} +{ + package Buh; + use Moose; + with 'Baw'; +} + +is exception { + Buh->new->push_attr(1); +}, undef, 'traits in role attributes are inflated properly'; + +{ + package Blorp; + use Moo::Role; + has attr => (is => 'ro'); +} + +is +Blorp->meta->get_attribute('attr')->name, 'attr', + 'role metaclass inflatable via ->meta'; + +done_testing; diff --git a/xt/moo-sification-handlemoose.t b/xt/moo-sification-handlemoose.t new file mode 100644 index 0000000..3c7c5a8 --- /dev/null +++ b/xt/moo-sification-handlemoose.t @@ -0,0 +1,19 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package Foo; + use Moo; + has one => (is => 'ro'); +} + +use Moo::HandleMoose; + +require Moo::sification; + +like exception { Moo::sification->unimport }, + qr/Can't disable Moo::sification after inflation has been done/, + 'Moo::sification can\'t be disabled after inflation'; + +done_testing; diff --git a/xt/moo-sification-meta.t b/xt/moo-sification-meta.t new file mode 100644 index 0000000..ae8ac31 --- /dev/null +++ b/xt/moo-sification-meta.t @@ -0,0 +1,40 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package Foo; + use Moo; + has one => (is => 'ro'); +} + +no Moo::sification; +is exception { Foo->meta->make_immutable }, undef, + 'make_immutable allowed under no Moo::sification'; + +like exception { Foo->meta->get_methods_list }, + qr/^Can't inflate Moose metaclass with Moo::sification disabled/, + 'meta methods blocked under no Moo::sification'; + +is exception { + is +Foo->meta->can('can'), \&Moo::HandleMoose::FakeMetaClass::can, + '->meta->can falls back to default under no Moo::sification'; +}, undef, + '->meta->can works under no Moo::sification'; + +is exception { + ok +Foo->meta->isa('Moo::HandleMoose::FakeMetaClass'), + '->meta->isa falls back to default under no Moo::sification'; +}, undef, + '->meta->isa works under no Moo::sification'; + +like exception { Foo->meta->get_methods_list }, + qr/^Can't inflate Moose metaclass with Moo::sification disabled/, + 'meta methods blocked under no Moo::sification'; + +require Moo::HandleMoose; +like exception { Moo::HandleMoose->import }, + qr/^Can't inflate Moose metaclass with Moo::sification disabled/, + 'Moo::HandleMoose->import blocked under no Moo::sification'; + +done_testing; diff --git a/xt/moo-sification.t b/xt/moo-sification.t new file mode 100644 index 0000000..b2ded40 --- /dev/null +++ b/xt/moo-sification.t @@ -0,0 +1,17 @@ +use Moo::_strictures; +use Test::More; + +BEGIN { + package Foo; + use Moo; + has one => (is => 'ro'); +} + +no Moo::sification; +use Moose; +use Class::MOP; + +is Class::MOP::get_metaclass_by_name('Foo'), undef, + 'no metaclass for Moo class after no Moo::sification'; + +done_testing; diff --git a/xt/moose-accessor-isa.t b/xt/moose-accessor-isa.t new file mode 100644 index 0000000..ad9753d --- /dev/null +++ b/xt/moose-accessor-isa.t @@ -0,0 +1,74 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package FrewWithIsa; + use Moo::Role; + use Sub::Quote; + + has frooh => ( + is => 'rw', + isa => sub { die 'not int' unless $_[0] =~ /^\d$/ }, + ); + + has frew => ( + is => 'rw', + isa => quote_sub(q{ die 'not int' unless $_[0] =~ /^\d$/ }), + ); + + package Bar; + use Moose; + with 'FrewWithIsa'; + + package OffByOne; + use Moo::Role; + + has off_by_one => (is => 'rw', coerce => sub { $_[0] + 1 }); + + package Baz; + use Moo; + + with 'OffByOne'; + + package Quux; + use Moose; + + with 'OffByOne'; + + __PACKAGE__->meta->make_immutable; +} + +is(exception { + Bar->new(frooh => 1, frew => 1); +}, undef, 'creation of valid Bar'); + +ok exception { + Bar->new(frooh => 'silly', frew => 1); +}, 'creation of invalid Bar validated by coderef'; + +ok exception { + Bar->new(frooh => 1, frew => 'goose'); +}, 'creation of invalid Bar validated by quoted sub'; + +sub test_off_by_one { + my ($class, $type) = @_; + + my $obo = $class->new(off_by_one => 1); + + is($obo->off_by_one, 2, "Off by one (new) ($type)"); + + $obo->off_by_one(41); + + is($obo->off_by_one, 42, "Off by one (set) ($type)"); +} + +test_off_by_one('Baz', 'Moo'); +test_off_by_one('Quux', 'Moose'); + +my $coerce_constraint = Quux->meta->get_attribute('off_by_one') + ->type_constraint->constraint; +like exception { $coerce_constraint->() }, qr/This is not going to work/, + 'generated constraint is not a null constraint'; + +done_testing; diff --git a/xt/moose-autoclean-lazy-attr-builders.t b/xt/moose-autoclean-lazy-attr-builders.t new file mode 100644 index 0000000..198e844 --- /dev/null +++ b/xt/moose-autoclean-lazy-attr-builders.t @@ -0,0 +1,30 @@ +use Moo::_strictures; +# when using an Moose object and namespace::autoclean +# lazy attributes that get a value on initialize still +# have their builders run + +{ + package MyMooseObject; + use Moose; +} + +{ + package BadObject; + use Moo; + # use MyMooseObject <- this is inferred here + use namespace::autoclean; + + has attr => ( is => 'lazy' ); + sub _build_attr {2} +} + +use Test::More; +# use BadObject <- this is inferred here + +is( + BadObject->new( attr => 1 )->attr, + 1, + q{namespace::autoclean doesn't run builders with default}, +); + +done_testing; diff --git a/xt/moose-consume-moo-role-after-consumed-by-moo.t b/xt/moose-consume-moo-role-after-consumed-by-moo.t new file mode 100644 index 0000000..ce54690 --- /dev/null +++ b/xt/moose-consume-moo-role-after-consumed-by-moo.t @@ -0,0 +1,32 @@ +use Moo::_strictures; +use Test::More; +use lib 't/lib'; +use InlineModule ( + 'MooRole' => q{ + package MooRole; + use Moo::Role; + + $::MooRole_LOADED++; + + no Moo::Role; + 1; + }, +); + +BEGIN { $::MooRole_LOADED = 0 } +BEGIN { + package MooConsumer; + use Moo; + + with "MooRole"; +} +BEGIN { + package MooseConsumer; + use Moose; + + with "MooRole"; +} + +is $::MooRole_LOADED, 1, "role loaded only once"; + +done_testing; diff --git a/xt/moose-consume-moo-role-no-moo-loaded.t b/xt/moose-consume-moo-role-no-moo-loaded.t new file mode 100644 index 0000000..5f389bf --- /dev/null +++ b/xt/moose-consume-moo-role-no-moo-loaded.t @@ -0,0 +1,18 @@ +use Moo::_strictures; +use Test::More; + +{ + package ExampleRole; + use Moo::Role; +} + +{ + package ExampleClass; + use Moose; + + with 'ExampleRole'; +} + +ok 1; + +done_testing; diff --git a/xt/moose-does-moo-role.t b/xt/moose-does-moo-role.t new file mode 100644 index 0000000..842c86a --- /dev/null +++ b/xt/moose-does-moo-role.t @@ -0,0 +1,74 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MooParentRole; + use Moo::Role; + sub parent_role_method { 1 }; + + package MooRole; + use Moo::Role; + with 'MooParentRole'; + sub role_method { 1 }; + + package MooRoledMooClass; + use Moo; + with 'MooRole'; + + has 'some_attr' => (is => 'ro'); + + package MooRoledMooseClass; + use Moose; + with 'MooRole'; + + has 'some_attr' => (is => 'ro'); + + package MooseParent; + use Moose; + + has e => ( + is => 'ro', + required => 1, + does => 'MooRole', + ); + + package MooParent; + use Moo; + + has e => ( + is => 'ro', + required => 1, + does => 'MooRole', + ); +} + +for my $parent (qw(MooseParent MooParent)) { + for my $child (qw(MooRoledMooClass MooRoledMooseClass)) { + is(exception { + my $o = $parent->new( + e => $child->new(), + ); + ok( $o->e->does("MooParentRole"), "$child does parent MooRole" ); + can_ok( $o->e, "role_method" ); + can_ok( $o->e, "parent_role_method" ); + ok($o->e->meta->has_method('role_method'), 'Moose knows about role_method'); + ok($o->e->meta->has_method('parent_role_method'), 'Moose knows about parent_role_method'); + }, undef); + } +} + +{ + package MooClass2; + use Moo; +} + +{ + ok !MooClass2->does('MooRole'), + 'Moo class does not do unrelated role'; + my $meta = Class::MOP::get_metaclass_by_name('MooClass2'); + is ref $meta, 'Moo::HandleMoose::FakeMetaClass', + 'does call for Moo only classes did not inflate'; +} + +done_testing; diff --git a/xt/moose-extend-moo.t b/xt/moose-extend-moo.t new file mode 100644 index 0000000..23b176f --- /dev/null +++ b/xt/moose-extend-moo.t @@ -0,0 +1,84 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +BEGIN { + package MooParent; + use Moo; + has message => ( is => 'ro', required => 1 ), +} + +BEGIN { + package Child; + use Moose; + extends 'MooParent'; + use Moose::Util::TypeConstraints; + use namespace::clean; # <-- essential + has message => ( + is => 'ro', isa => 'Str', + lazy => 1, + default => sub { 'overridden message sub here' }, + ); +} +# without namespace::clean, gives the (non-fatal) warning: +# You are overwriting a locally defined function (message) with an accessor +# ...because Moose::Util::TypeConstraints exports a 'message' sub! + +my $obj = Child->new(message => 'custom message'); + +is($obj->message, 'custom message', 'accessor works'); + +BEGIN { + package Role1; + use Moo::Role; +} + +BEGIN { + package Role2; + use Moose::Role; +} + +BEGIN { + package Class1; + use Moo; + with 'Role1'; +} + +BEGIN { + package Class2; + use Moose; + extends 'Class1'; + with 'Role2'; +} + +ok +Class2->does('Role1'), "Moose child does parent's composed roles"; +ok +Class2->does('Role2'), "Moose child does child's composed roles"; + +BEGIN { + package NonMooParent; + sub new { + bless {}, $_[0]; + } +} +BEGIN { + package MooChild; + use Moo; + extends 'NonMooParent'; + has attr1 => (is => 'ro'); + with 'Role1'; +} +BEGIN { + package MooseChild; + use Moose; + extends 'MooChild'; + with 'Role2'; + has attr2 => (is => 'ro'); +} + +is exception { MooseChild->new }, undef, 'NonMoo->Moo->Moose(mutable) works'; +MooseChild->meta->make_immutable(inline_constructor => 0); +is exception { MooseChild->new }, undef, 'NonMoo->Moo->Moose(immutable) works'; + +ok +MooseChild->does('Role2'), "Moose child does parent's composed roles with non-Moo ancestor"; + +done_testing; diff --git a/xt/moose-handles-moo-class.t b/xt/moose-handles-moo-class.t new file mode 100644 index 0000000..5e3ef5a --- /dev/null +++ b/xt/moose-handles-moo-class.t @@ -0,0 +1,22 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moo; + sub sub1 { 1 } +} +{ + package Bar; + use Moose; + ::is ::exception { + has attr => ( + is => 'ro', + isa => 'Foo', + handles => qr/.*/, + ); + }, undef, 'regex handles in Moose with Moo class isa'; +} + +done_testing; diff --git a/xt/moose-inflate-error-recurse.t b/xt/moose-inflate-error-recurse.t new file mode 100644 index 0000000..e3f3a72 --- /dev/null +++ b/xt/moose-inflate-error-recurse.t @@ -0,0 +1,63 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +use Moose (); +BEGIN { + my $sigwarn = $SIG{__WARN__}; + $SIG{__WARN__} = sub { + die $_[0] + if $_[0] =~ /Deep recursion/; + if ($sigwarn) { + no strict 'refs'; + goto &$sigwarn; + } + else { + warn $_[0]; + } + }; +} + +BEGIN { + package Role1; + use Moo::Role; + has attr1 => (is => 'ro', lazy => 1); +} +BEGIN { + package Class1; + use Moo; + with 'Role1'; +} +BEGIN { + package SomeMooseClass; + use Moose; + ::like( + ::exception { with 'Role1' }, + qr/You cannot have a lazy attribute/, + 'reasonable error rather than deep recursion for inflating invalid attr', + ); +} + +BEGIN { + package WTF::Trait; + use Moose::Role; + use Moose::Util; + Moose::Util::meta_attribute_alias('WTF'); + has wtf => (is => 'ro', required => 1); +} + +BEGIN { + package WTF::Class; + use Moo; + has ftw => (is => 'ro', traits => [ 'WTF' ]); +} + +like( + exception { + WTF::Class->meta->get_attribute('ftw'); + }, + qr/Attribute \(wtf\) is required/, + 'reasonable error rather than deep recursion for inflating invalid attr (traits)', +); + +done_testing; diff --git a/xt/moose-lazy.t b/xt/moose-lazy.t new file mode 100644 index 0000000..949e3ec --- /dev/null +++ b/xt/moose-lazy.t @@ -0,0 +1,71 @@ +use Moo::_strictures; +use Test::More; + +{ + package LazyFrew; + + our $default_ran = 0; + our $quoted_default_ran = 0; + our $builder_ran = 0; + + use Moo::Role; + use Sub::Quote; + + has frooh => ( + is => 'rw', + default => sub { + $default_ran = 1; + 'test frooh' + }, + lazy => 1, + ); + + has frew => ( + is => 'rw', + default => quote_sub(q{ + $$quoted_default_ran = 1; + 'test frew' + }, { '$quoted_default_ran' => \\$quoted_default_ran }), + lazy => 1, + ); + + has frioux => ( + is => 'rw', + builder => 'build_frioux', + lazy => 1, + ); + + sub build_frioux { + $builder_ran = 1; + 'test frioux' + } + + package Bar; + use Moose; + with 'LazyFrew'; +} + +my $x = Bar->new; +ok(!$LazyFrew::default_ran, 'default has not run yet'); +ok(!$LazyFrew::quoted_default_ran, 'quoted default has not run yet'); +ok(!$LazyFrew::builder_ran, 'builder has not run yet'); + +is($x->frooh, 'test frooh', 'frooh defaulted correctly'); + +ok($LazyFrew::default_ran, 'default ran'); +ok(!$LazyFrew::quoted_default_ran, 'quoted default has not run yet'); +ok(!$LazyFrew::builder_ran, 'builder has not run yet'); + +is($x->frew, 'test frew', 'frew defaulted correctly'); + +ok($LazyFrew::default_ran, 'default ran'); +ok($LazyFrew::quoted_default_ran, 'quoted default ran'); +ok(!$LazyFrew::builder_ran, 'builder has not run yet'); + +is($x->frioux, 'test frioux', 'frioux built correctly'); + +ok($LazyFrew::default_ran, 'default ran'); +ok($LazyFrew::quoted_default_ran, 'quoted default ran'); +ok($LazyFrew::builder_ran, 'builder ran'); + +done_testing; diff --git a/xt/moose-method-modifiers.t b/xt/moose-method-modifiers.t new file mode 100644 index 0000000..a3b1ac8 --- /dev/null +++ b/xt/moose-method-modifiers.t @@ -0,0 +1,61 @@ +use Moo::_strictures; +use Test::More; + +{ + package ModifyFoo; + use Moo::Role; + + our $before_ran = 0; + our $around_ran = 0; + our $after_ran = 0; + + before foo => sub { $before_ran = 1 }; + after foo => sub { $after_ran = 1 }; + around foo => sub { + my ($orig, $self, @rest) = @_; + $self->$orig(@rest); + $around_ran = 1; + }; + + package Bar; + use Moose; + with 'ModifyFoo'; + + sub foo { } +} + +my $bar = Bar->new; + +ok(!$ModifyFoo::before_ran, 'before has not run yet'); +ok(!$ModifyFoo::after_ran, 'after has not run yet'); +ok(!$ModifyFoo::around_ran, 'around has not run yet'); +$bar->foo; +ok($ModifyFoo::before_ran, 'before ran'); +ok($ModifyFoo::after_ran, 'after ran'); +ok($ModifyFoo::around_ran, 'around ran'); + +{ + package ModifyMultiple; + use Moo::Role; + our $before = 0; + + before 'foo', 'bar' => sub { + $before++; + }; + + package Baz; + use Moose; + with 'ModifyMultiple'; + + sub foo {} + sub bar {} +} + +my $baz = Baz->new; +my $pre = $ModifyMultiple::before; +$baz->foo; +is $ModifyMultiple::before, $pre+1, "before applies to first of multiple subs"; +$baz->bar; +is $ModifyMultiple::before, $pre+2, "before applies to second of multiple subs"; + +done_testing; diff --git a/xt/moose-override-attribute-from-moo-role.t b/xt/moose-override-attribute-from-moo-role.t new file mode 100644 index 0000000..fae0339 --- /dev/null +++ b/xt/moose-override-attribute-from-moo-role.t @@ -0,0 +1,39 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MyRole; + use Moo::Role; + + has foo => ( + is => 'ro', + required => 1, + ); +} +{ + package MyClass; + use Moose; + + with 'MyRole'; + + has '+foo' => ( + isa => 'Str', + ); +} + +is( + exception { MyClass->new(foo => 'bar') }, + undef, + 'construct' +); +ok( + exception { MyClass->new(foo => []) }, + 'no construct, constraint works' +); +ok( + exception { MyClass->new() }, + 'no construct - require still works' +); + +done_testing; diff --git a/xt/moose-override-attribute-with-plus-syntax.t b/xt/moose-override-attribute-with-plus-syntax.t new file mode 100644 index 0000000..748dbe9 --- /dev/null +++ b/xt/moose-override-attribute-with-plus-syntax.t @@ -0,0 +1,60 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +{ + package MooParent; + use Moo; + + has foo => ( + is => 'ro', + default => sub { 'MooParent' }, + ); +} +{ + package MooseChild; + use Moose; + extends 'MooParent'; + + has '+foo' => ( + default => 'MooseChild', + ); +} +{ + package MooseChild2; + use Moose; + extends 'MooParent'; + + has '+foo' => ( + default => 'MooseChild2', + ); + __PACKAGE__->meta->make_immutable +} +{ + package MooChild; + use Moo; + extends 'MooParent'; + + has '+foo' => ( + default => sub { 'MooChild' }, + ); +} + +is( + MooseChild->new->foo, + 'MooseChild', + 'default value in Moose child' +); + +is( + MooseChild2->new->foo, + 'MooseChild2', + 'default value in Moose child' +); + +is(exception { + local $SIG{__WARN__} = sub { die $_[0] }; + ok(MooChild->meta->has_attribute('foo'), 'inflated metaclass has overridden attribute'); +}, undef, 'metaclass inflation of plus override works without warnings'); + +done_testing; diff --git a/xt/more-jenga.t b/xt/more-jenga.t new file mode 100644 index 0000000..e5aee2b --- /dev/null +++ b/xt/more-jenga.t @@ -0,0 +1,40 @@ +use Moo::_strictures; +use Test::More; +use lib 't/lib'; +use InlineModule ( + MooseRoleOne => q{ + package MooseRoleOne; + use Moose::Role; + 1; + }, + MooseRoleTwo => q{ + package MooseRoleTwo; + use Moose::Role; + 1; + }, +); + +{ + package MooRoleWithMooseRoles; + use Moo::Role; + + requires 'foo'; + + with qw/ + MooseRoleOne + MooseRoleTwo + /; +} + +{ + package MooseClassWithMooRole; + use Moose; + + with 'MooRoleWithMooseRoles'; + + sub foo {} +} + +ok 1, 'classes and roles built without error'; + +done_testing; diff --git a/xt/release/kwalitee.t b/xt/release/kwalitee.t new file mode 100644 index 0000000..8b3726d --- /dev/null +++ b/xt/release/kwalitee.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +BEGIN { + plan skip_all => 'these tests are for release candidate testing' + unless $ENV{RELEASE_TESTING}; +} + +use CPAN::Meta; +use Test::Kwalitee 'kwalitee_ok'; + +my ($meta_file) = grep -e, qw(MYMETA.json MYMETA.yml META.json META.yml) + or die "unable to find MYMETA or META file!"; + +my $meta = CPAN::Meta->load_file($meta_file)->as_struct; +my @ignore = keys %{$meta->{x_cpants}{ignore}}; + +kwalitee_ok(map "-$_", @ignore); +done_testing; diff --git a/xt/role-tiny-inflate.t b/xt/role-tiny-inflate.t new file mode 100644 index 0000000..d04c5fc --- /dev/null +++ b/xt/role-tiny-inflate.t @@ -0,0 +1,45 @@ +use Moo::_strictures; +use Test::More; + +eval q{ + package TinyRole; + $INC{'TinyRole.pm'} = __FILE__; + use Role::Tiny; + + sub role_tiny_method { 219 } + 1; +} or die $@; + +require Moo::Role; +require Moose; + +eval q{ + package TinyRoleAfterMoo; + $INC{'TinyRoleAfterMoo.pm'} = __FILE__; + use Role::Tiny; + + sub role_tiny_after_method { 42 } + 1; +} or die $@; + +eval q{ + package Some::Moose::Class; + use Moose; + 1; +} or die $@; + +eval q{ + package Some::Moose::Class; + with 'TinyRole'; +}; +$@ =~ s/\n.*//s; +is $@, '', 'Moose can consume Role::Tiny created before Moo loaded'; + +eval q{ + package Some::Moose::Class; + with 'TinyRoleAfterMoo'; +}; +$@ =~ s/\n.*//s; +is $@, '', 'Moose can consume Role::Tiny created after Moo loaded'; + +done_testing; diff --git a/xt/super-jenga.t b/xt/super-jenga.t new file mode 100644 index 0000000..9973dd4 --- /dev/null +++ b/xt/super-jenga.t @@ -0,0 +1,52 @@ +use Moo::_strictures; +use Test::More "$]" < 5.008009 + ? (skip_all => 'Mouse is broken on perl <= 5.8.8') + : (); + +{ + package Tower1; + + use Mouse; + + has 'attr1' => (is => 'ro', required => 1); + + package Tower2; + + use Moo; + + extends 'Tower1'; + + has 'attr2' => (is => 'ro', required => 1); + + package Tower3; + + use Moose; + + extends 'Tower2'; + + has 'attr3' => (is => 'ro', required => 1); + + __PACKAGE__->meta->make_immutable; + + package Tower4; + use Moo; + + extends 'Tower1'; + + has 'attr1' => (is => 'ro', required => 1); + has 'attr2' => (is => 'ro', required => 1); + has 'attr3' => (is => 'ro', required => 1); + has 'attr4' => (is => 'ro', required => 1); +} + +foreach my $num (1..4) { + my $class = "Tower${num}"; + my @attrs = map "attr$_", 1..$num; + my %args = map +($_ => "${_}_value"), @attrs; + my $obj = $class->new(%args); + is($obj->{$_}, "${_}_value", "Attribute $_ ok for $class") for @attrs; + is Class::MOP::get_metaclass_by_name($class)->name, $class, + 'metaclass inflated correctly'; +} + +done_testing; diff --git a/xt/test-my-dependents.t b/xt/test-my-dependents.t new file mode 100644 index 0000000..902d1ef --- /dev/null +++ b/xt/test-my-dependents.t @@ -0,0 +1,314 @@ +use Test::More; +BEGIN { + plan skip_all => <<'END_HELP' unless $ENV{MOO_TEST_MD} || @ARGV; +This test will not run unless you set MOO_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 (hundreds). + + Dist::1,Dist::2,... Test the individual dists listed. + + MooX Test all Moo extension distros. + + 1 Run the default tests. We pick 200 random dists and + test them. +END_HELP +} + +use Test::DependentModules qw( test_module ); +use JSON::PP; +use HTTP::Tiny; +use List::Util (); +use Cwd (); +use Getopt::Long (); +use Config; + +my @extra_libs = do { + my @libs = `"$^X" -le"print for \@INC"`; + chomp @libs; + my %libs; @libs{@libs} = (); + map { Cwd::abs_path($_) } grep { !exists $libs{$_} } @INC; +}; +$ENV{PERL5LIB} = join($Config{path_sep}, @extra_libs, $ENV{PERL5LIB}||()); + +Getopt::Long::GetOptions( + 'show' => \(my $show), + 'all' => \(my $all), + 'save-skip=s' => \(my $save_skip), + 'skip-file=s' => \(my $skip_file), + 'count=s' => \(my $count), + 'moox' => \(my $moox), +); + +my @pick = @ARGV; +if (my $env = $ENV{MOO_TEST_MD}) { + if ($env eq 'MooX') { + $moox = 1; + } + elsif ($env eq 'all') { + $all = 1; + } + elsif ($env =~ /^\d+$/) { + $count = $env; + } + else { + @pick = split /,/, $env; + s/^\s+//, s/\s+$// for @pick; + } +} + +# avoid any modules that depend on these +my @bad_prereqs = qw(Gtk2 Padre Wx); + +my $res = decode_json(HTTP::Tiny->new->post( + 'http://api.metacpan.org/v0/search/reverse_dependencies/Moo', + { content => encode_json({ + query => { + filtered => { + query => { "match_all" => {} }, + filter => { + and => [ + { term => { 'release.status' => 'latest' } }, + { term => { 'release.authorized' => \1 } }, + { not => { filter => { + or => [ + map { { term => { 'dependency.module' => $_ } } } @bad_prereqs, + ], + } } } + ], + }, + }, + }, + size => 5000, + fields => ['distribution', 'provides', 'metadata.provides'], + }) }, +)->{content}); + +my %bad_dist; +my $sec_reason; +my %skip; +my %todo; + +my $hash; + +my $skip_fh; +if ($skip_file) { + open $skip_fh, '<', $skip_file + or die "can't open $skip_file: $!"; +} +else { + $skip_fh = \*DATA; +} +while (my $line = <$skip_fh>) { + chomp $line; + next unless $line =~ /\S/; + if ( $line =~ /^#\s*(\w+)(?::\s*(.*?)\s*)?$/ ) { + die "Invalid action in DATA section ($1)" + unless $1 eq 'SKIP' || $1 eq 'TODO'; + $hash = $1 eq 'SKIP' ? \%skip : \%todo; + $sec_reason = $2; + } + + my ( $dist, $reason ) = $line =~ /^(\S*)\s*(?:#\s*(.*?)\s*)?$/; + next unless defined $dist && length $dist; + + $hash->{$dist} = $reason ? "$sec_reason: $reason" : $reason; +} + +my %todo_module; +my %skip_module; +my %dists; +my @modules; +for my $hit (@{ $res->{hits}{hits} }) { + my $dist = $hit->{fields}{distribution}; + + my $module = (sort { length $a <=> length $b || $a cmp $b } do { + if (my $provides = $hit->{fields}{provides}) { + ref $provides ? @$provides : ($provides); + } + elsif (my $provides = $hit->{fields}{'metadata.provides'}) { + keys %$provides; + } + else { + (my $module = $dist) =~ s/-/::/g; + ($module); + } + })[0]; + $todo_module{$module} = $todo{$dist} + if exists $todo{$dist}; + $skip_module{$module} = $skip{$dist} + if exists $skip{$dist}; + if ($dist =~ /^(Task|Bundle|Acme)-/) { + $skip_module{$module} = "not testing $1 dist"; + } + $dists{$module} = $dist; + push @modules, $module; + $module; +} +@modules = sort @modules; + +if ( $moox ) { + @modules = grep /^MooX(?:$|::)/, @modules; +} +elsif ( $count ) { + $count = $count == 1 ? 200 : $count; + diag(<<"EOF"); + Picking $count random dependents to test. Set MOO_TEST_MD=all to test all + dependents or MOO_TEST_MD=MooX to test extension modules only. +EOF + @modules = grep { !exists $skip_modules{$_} } List::Util::shuffle(@modules); + @modules = @modules[0 .. $count-1]; +} +elsif ( @pick ) { + my %modules = map { $_ => 1 } @modules; + if (my @unknown = grep { !$modules{$_} } @pick) { + die "Unknown modules: @unknown"; + } + delete @skip_modules{@pick}; + @modules = @pick; +} + +if ($show) { + print "Dependents:\n"; + print " $_\n" for @modules; + exit; +} + +my $skip_report; +if ($save_skip) { + open $skip_report, '>', $save_skip + or die "can't open $save_skip: $!"; + print { $skip_report } "# SKIP: saved failures\n" +} + +plan tests => scalar @modules; +for my $module (@modules) { + SKIP: { + local $TODO = $todo_module{$module} || '???' + if exists $todo_module{$module}; + skip "$module - " . ($skip_module{$module} || '???'), 1 + if exists $skip_module{$module}; + test_module($module); + if ($skip_report) { + my $last = (Test::More->builder->details)[-1]; + if (! $last->{ok}) { + my $name = $last->{name}; + $name =~ s/\s.*//; + $name =~ s/^\Q$dists{$module}-//; + print { $skip_report } "$dists{$module} # $name\n"; + } + } + } +} + +__DATA__ + +# TODO: broken +App-Presto # 0.009 +Dancer2-Session-Sereal # 0.001 +Mail-GcalReminder # 0.1 +DBIx-Class-IndexSearch-Dezi # 0.05 +Tak # 0.001003 +HTML-Zoom-Parser-HH5P # 0.002 +Farabi # 0.44 +MooX-Types-CLike # 0.92 +Net-Easypost # 0.09 +OAuth2-Google-Plus # 0.02 +Protocol-Star-Linemode # 1.0.0 +Vim-X # 0.2.0 +WWW-eNom # v1.2.8 - the internet changes +WebService-Cryptsy # 1.008003 +Dancer2-Plugin-REST # 0.21 +Config-GitLike # 1.13 +WWW-ThisIsMyJam # v0.1.0 +Dancer2-Session-JSON # 0.001 +App-Kit # 0.26 - db test segfaults +Data-Record-Serialize # 0.05 - dbi test fails + +# TODO: broken prereqs +Dancer-Plugin-FontSubset # 0.1.2 - Font::TTF::Scripts::Name +App-Unicheck-Modules-MySQL # 0.02 - DBD::mysql +Video-PlaybackMachine # 0.09 - needs X11::FullScreen +Games-Snake # 0.000001 - SDL +Data-SimplePassword # 0.10 - Crypt::Random, Math::Pari +Dancer2-Plugin-Queue # 0.004 - Dancer2 0.08 +MarpaX-Grammar-GraphViz2 # 1.00 - GraphViz2 +Nitesi # 0.0094 - Crypt::Random, Math::Pari +POEx-ZMQ3 # 0.060003 - ZMQ::LibZMQ3 +Unicorn-Manager # 0.006009 - Net::Interface +Wight-Chart # 0.003 - Wight +Yakuake-Sessions # 0.11.1 - Net::DBus +Jedi-Plugin-Auth # 0.01 - Jedi +Minilla # v0.14.1 +Perinci-CmdLine # 0.85 - via SHARYANTO +Perinci-To-Text # 0.22 - via SHARYANTO +Perinci-Sub-To-Text # 0.24 - via SHARYANTO +Software-Release-Watch # 0.01 - via SHARYANTO +Software-Release-Watch-SW-wordpress # 0.01 - via Software::Release::Watch +Org-To-HTML # 0.11 - via Perinci::* + +# TODO: undeclared prereqs +Catmandu-Inspire # v0.24 - Furl + +# TODO: broken by perl 5.18 +App-DBCritic # 0.020 - smartmatch (GH #9) +Authen-HTTP-Signature # 0.02 - smartmatch (rt#88854) +DBICx-Backend-Move # 1.000010 - smartmatch (rt#88853) +Ruby-VersionManager # 0.004003 - smartmatch (rt#88852) +Text-Keywords # 0.900 - smartmatch (rt#84339) +WebService-HabitRPG # 0.21 - smartmatch (rt#88399) +Net-Icecast2 # 0.005 - hash order via PHP::HTTPBuildQuery (rt#81570) +POE-Component-ProcTerminator # 0.03 - hash order via Log::Fu (rt#88851) +Plugin-Tiny # 0.012 - hash order +Firebase # 0.0201 - hash order + +# TODO: broken by Regexp::Grammars (perl 5.18) +Language-Expr # 0.19 +Org-To-HTML # 0.07 - via Language::Expr +Perinci-Access-Simple-Server # 0.12 + +# TODO: invalid prereqs +Catmandu-Z3950 # 0.03 - ZOOM missing +Dancer2-Session-JSON # 0.001 - Dancer2 bad version requirement +Business-CPI-Gateway-Moip # 0.05 - Business::CPI::Buyer +Business-OnlinePayment-IPayment # 0.05 - XML::Compile::WSDL11 +WebService-BambooHR # 0.04 - LWP::Online +WWW-AdServeApache2-HttpEquiv # 1.00r - unlisted dep Geo::IP +WWW-AdServer # 1.01 - unlisted dep Geo::IP +CatalystX-Usul # 0.17.1 - issues in prereq chain +Dancer2-Template-Haml # 0.04 - unlisted dep Text::Haml + +# SKIP: misc +Apache2-HttpEquiv # 1.00 - prereq Apache2::Const +GeoIP2 # 0.040000 - prereq Math::Int128 (requires gcc 4.4) +Graphics-Potrace # 0.72 - external dependency +GraphViz2 # 2.19 - external dependency +Linux-AtaSmart # OS specific +MaxMind-DB-Reader # 0.040003 - prereq Math::Int128 (requires gcc 4.4) +MaxMind-DB-Common # 0.031002 - prereq Math::Int128 (requires gcc 4.4) +Net-Works # 0.12 - prereq Math::Int128 (requires gcc 4.4) +PortageXS # 0.3.1 - external dependency and broken prereq (Shell::EnvImporter) +XML-GrammarBase # v0.2.2 - prereq XML::LibXSLT (hard to install) +Forecast-IO # 0.21 - interactive tests +Net-OpenVPN-Launcher # 0.1 - external dependency (and broken test) +App-PerlWatcher-Level # 0.13 - depends on Linux::Inotify2 +Graph-Easy-Marpa # 2.00 - GraphVis2 +Net-OAuth-LP # 0.016 - relies on external service +Message-Passing-ZeroMQ # 0.007 - external dependency +Net-Docker # 0.002003 - external dependency +App-PerlWatcher-Watcher-FileTail # 0.18 - Linux::Inotify2 +switchman # 1.05 - Linux::MemInfo +Juno # 0.009 - never finishes +Zucchini # 0.0.21 - broken by File::Rsync +ZMQ-FFI # 0.12 - libzmq +MaxMind-DB-Reader-XS # 0.060003 - external lib libmaxminddb +Cave-Wrapper # 0.01100100 - external program cave +Tropo # 0.16 - openssl >= 1.0.0? + +# TODO: broken by Moo change +Math-Rational-Approx # RT#84035 +App-Services # RT#85255 +Hg-Lib # pending release diff --git a/xt/type-inflate-coercion.t b/xt/type-inflate-coercion.t new file mode 100644 index 0000000..1ec17dd --- /dev/null +++ b/xt/type-inflate-coercion.t @@ -0,0 +1,45 @@ +use Moo::_strictures; +use Test::More; +use Test::Fatal; + +sub ArrayRef { + my $type = sub { + die unless ref $_[0] && ref $_[0] eq 'ARRAY'; + }; + $Moo::HandleMoose::TYPE_MAP{$type} = sub { + require Moose::Util::TypeConstraints; + Moose::Util::TypeConstraints::find_type_constraint("ArrayRef"); + }; + return ($type, @_); +} + +{ + package ClassWithTypes; + $INC{'ClassWithTypes.pm'} = __FILE__; + use Moo; + + has split_comma => (is => 'ro', isa => ::ArrayRef, coerce => sub { [ split /,/, $_[0] ] } ); + has split_space => (is => 'ro', isa => ::ArrayRef, coerce => sub { [ split / /, $_[0] ] } ); + has bad_coerce => (is => 'ro', isa => ::ArrayRef, coerce => sub { $_[0] } ); +} + +my $o = ClassWithTypes->new(split_comma => 'a,b c,d', split_space => 'a,b c,d'); +is_deeply $o->split_comma, ['a','b c','d'], 'coerce with prebuilt type works'; +is_deeply $o->split_space, ['a,b','c,d'], ' ... and with different coercion on same type'; + +{ + package MooseSubclassWithTypes; + use Moose; + extends 'ClassWithTypes'; +} + +my $o2 = MooseSubclassWithTypes->new(split_comma => 'a,b c,d', split_space => 'a,b c,d'); +is_deeply $o2->split_comma, ['a','b c','d'], 'moose subclass has correct coercion'; +is_deeply $o2->split_space, ['a,b','c,d'], ' ... and with different coercion on same type'; + +like + exception { MooseSubclassWithTypes->new(bad_coerce => 1) }, + qr/Validation failed for 'ArrayRef' with value/, + 'inflated type has correct name'; + +done_testing; diff --git a/xt/type-inflate-threads.t b/xt/type-inflate-threads.t new file mode 100644 index 0000000..cb35d6c --- /dev/null +++ b/xt/type-inflate-threads.t @@ -0,0 +1,64 @@ +use Config; +BEGIN { + unless ($Config{useithreads}) { + print "1..0 # SKIP your perl does not support ithreads\n"; + exit 0; + } +} +use threads; +use Moo::_strictures; +use Test::More; +use Type::Tiny; + +my $str = sub { + die unless defined $_[0] && !ref $_[0]; +}; +$Moo::HandleMoose::TYPE_MAP{$str} = sub { + require Moose::Util::TypeConstraints; + Moose::Util::TypeConstraints::find_type_constraint("Str"); +}; + +my $int = Type::Tiny->new( + name => "Integer", + constraint => sub { /^(?:-?[1-9][0-9]*|0)$|/ }, + message => sub { "$_ isn't an integer" }, +); +require Moo; + +is(threads->create(sub { + my $type = $str; + eval q{ + package TypeOMatic; + use Moo; + has str_type => ( + is => 'ro', + isa => $type, + ); + 1; + } or die $@; + + require Moose; + my $meta = Class::MOP::class_of('TypeOMatic'); + my $str_name = $meta->get_attribute("str_type")->type_constraint->name; + $str_name; +})->join, 'Str', 'Type created outside thread properly inflated'); + +is(threads->create(sub { + my $type = $int; + eval q{ + package TypeOMatic; + use Moo; + has int_type => ( + is => 'ro', + isa => $type, + ); + 1; + } or die $@; + + require Moose; + my $meta = Class::MOP::class_of('TypeOMatic'); + my $int_class = ref $meta->get_attribute("int_type")->type_constraint; + $int_class; +})->join, 'Type::Tiny', 'Type::Tiny created outside thread inflates to self'); + +done_testing; diff --git a/xt/type-inflate-type-tiny.t b/xt/type-inflate-type-tiny.t new file mode 100644 index 0000000..9c4efff --- /dev/null +++ b/xt/type-inflate-type-tiny.t @@ -0,0 +1,41 @@ +use Moo::_strictures; +use Test::More; + +{ + package TypeOMatic; + + use Moo::Role; + use Sub::Quote; + use Moo::HandleMoose (); + use Types::Standard qw(Str); + + has consumed_type => ( + is => 'ro', + isa => Str, + ); + + package TypeOMatic::Consumer; + + # do this as late as possible to simulate "real" behaviour + use Moo::HandleMoose; + use Moose; + use Types::Standard qw(Str); + + with 'TypeOMatic'; + + has direct_type => ( + is => 'ro', + isa => Str, + ); +} + +my $meta = Class::MOP::class_of('TypeOMatic::Consumer'); + +for my $attr (qw(consumed_type direct_type)) { + my $type = $meta->get_attribute($attr)->type_constraint; + + isa_ok($type, 'Type::Tiny'); + is($type->name, 'Str'); +} + +done_testing; diff --git a/xt/type-inflate.t b/xt/type-inflate.t new file mode 100644 index 0000000..da72ab9 --- /dev/null +++ b/xt/type-inflate.t @@ -0,0 +1,80 @@ +use Moo::_strictures; +use Test::More; + +{ + package TypeOMatic; + + use Moo::Role; + use Sub::Quote; + use Moo::HandleMoose (); + + sub Str { + my $type = sub { + die unless defined $_[0] && !ref $_[0]; + }; + $Moo::HandleMoose::TYPE_MAP{$type} = sub { + require Moose::Util::TypeConstraints; + Moose::Util::TypeConstraints::find_type_constraint("Str"); + }; + return ($type, @_); + } + sub PositiveInt { + my $type = sub { + die unless defined $_[0] && !ref $_[0] && $_[0] =~ /^-?\d+/; + }; + $Moo::HandleMoose::TYPE_MAP{$type} = sub { + require Moose::Util::TypeConstraints; + require MooseX::Types::Common::Numeric; + Moose::Util::TypeConstraints::find_type_constraint( + "MooseX::Types::Common::Numeric::PositiveInt"); + }; + return ($type, @_); + } + + has named_type => ( + is => 'ro', + isa => Str, + ); + + has named_external_type => ( + is => 'ro', + isa => PositiveInt, + ); + + package TypeOMatic::Consumer; + + # do this as late as possible to simulate "real" behaviour + use Moo::HandleMoose; + use Moose; + with 'TypeOMatic'; +} + +my $meta = Class::MOP::class_of('TypeOMatic::Consumer'); + +my ($str, $positive_int) + = map $meta->get_attribute($_)->type_constraint->name, + qw(named_type named_external_type); + +is($str, 'Str', 'Built-in Moose type ok'); +is( + $positive_int, 'MooseX::Types::Common::Numeric::PositiveInt', + 'External (MooseX::Types type) ok' +); + +local $@; +eval q { + package Fooble; + use Moo; + my $isa = sub { 1 }; + $Moo::HandleMoose::TYPE_MAP{$isa} = sub { $isa }; + has barble => (is => "ro", isa => $isa); + __PACKAGE__->meta->get_attribute("barble"); +}; + +like( + $@, + qr/^error inflating attribute 'barble' for package 'Fooble': \$TYPE_MAP\{CODE\(\w+?\)\} did not return a valid type constraint/, + 'error message for incorrect type constraint inflation', +); + +done_testing; diff --git a/xt/type-tiny-coerce.t b/xt/type-tiny-coerce.t new file mode 100644 index 0000000..fab88ed --- /dev/null +++ b/xt/type-tiny-coerce.t @@ -0,0 +1,22 @@ +use Moo::_strictures; +use Test::More; + +{ + package Goo; + use Moo; + use Types::Standard qw(Int Num); + + has foo => ( + is => 'ro', + isa => Int->plus_coercions(Num, q{ int($_) }), + coerce => 1, + ); +} + +my $obj = Goo->new( + foo => 3.14159, +); + +is($obj->foo, '3', 'Type::Tiny coercion applied with coerce => 1'); + +done_testing; diff --git a/xt/withautoclean.t b/xt/withautoclean.t new file mode 100644 index 0000000..1dee0e6 --- /dev/null +++ b/xt/withautoclean.t @@ -0,0 +1,42 @@ +use Moo::_strictures; +use lib "t/lib"; +use Test::More; +use InlineModule ( + 'withautoclean::Class' => q{ + package withautoclean::Class; + use Moo; + + with 'withautoclean::Role'; + + before _clear_ctx => sub {}; + + 1; + }, + 'withautoclean::Role' => q{ + package withautoclean::Role; + use Moo::Role; + + # Doing this (or loading a class which is built with Moose) + # and then loading autoclean - everything breaks... + use Moose (); + use namespace::autoclean; + # Wouldn't happen normally, but is likely to as you part-port something. + + has _ctx => ( + is => 'ro', + default => sub { + }, + clearer => '_clear_ctx', + ); + + 1; + }, +); + +use_ok 'withautoclean::Class'; + +my $o = withautoclean::Class->new(_ctx => 1); +$o->_clear_ctx; +is $o->_ctx, undef, 'modified method works'; + +done_testing;