openkylin
/
libmoo-perl
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Import Upstream version 2.003006

This commit is contained in:
Lu zhiping 2022-07-16 18:07:22 +08:00
commit 2d4420da40
149 changed files with 14174 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

610
Changes Normal file
View File

@ -0,0 +1,610 @@
Revision history for Moo
2.003006 - 2019-10-25
- update Role::Tiny prerequisite to 2.001004 to fix issues with re-importing
Moo::Role
2.003_005 - 2019-10-18
- always exclude helper subs (has, with, etc) from the list of methods, even
if they are installed later or wrapped with a modifier
- drop Devel::GlobalDestruction prerequisite unless using perl < 5.14
- fix preserving full accuracy of numbers in non-ref defaults
- fix tracking of stubs and constants as methods to be consistent and work
properly with unusual ways of storing subs (RT#130050)
- fix test for modules broken by newer Moo versions when new enough
CPAN::Meta version is not available
- fix undeferring subs before wrapping with a method modifier when subs to
wrap are given as a list or array ref
- fix error reporting locations from Carp calls in DEMOLISH (RT#124845)
- fix extending attributes (has +) to allow overriding a default with a
builder (RT#130361)
- fix re-throwing Moose inflation exceptions when examining exception
objects on older Moose or Devel::StackTrace versions
- reorganized documentation related to Moose to improve clarity
- improved documentation of usage with namespace::clean
- various documentation tweaks
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

374
LICENSE Normal file
View File

@ -0,0 +1,374 @@
Terms of the Perl programming language system itself
a) the GNU General Public License as published by the Free
Software Foundation; either version 1, or (at your option) any
later version, or
b) the "Artistic License"
--- The GNU General Public License, Version 1, February 1989 ---
This software is Copyright (c) 2019 by mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>.
This is free software, licensed under:
The GNU General Public License, Version 1, February 1989
GNU GENERAL PUBLIC LICENSE
Version 1, February 1989
Copyright (C) 1989 Free Software Foundation, Inc.
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The license agreements of most software companies try to keep users
at the mercy of those companies. By contrast, our General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of a such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must tell them their rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any program or other work which
contains a notice placed by the copyright holder saying it may be
distributed under the terms of this General Public License. The
"Program", below, refers to any such program or work, and a "work based
on the Program" means either the Program or any work containing the
Program or a portion of it, either verbatim or with modifications. Each
licensee is addressed as "you".
1. You may copy and distribute verbatim copies of the Program's source
code as you receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
a) cause the modified files to carry prominent notices stating that
you changed the files and the date of any change; and
b) cause the whole of any work that you distribute or publish, that
in whole or in part contains the Program or any part thereof, either
with or without modifications, to be licensed at no charge to all
third parties under the terms of this General Public License (except
that you may choose to grant warranty protection to some or all
third parties, at your option).
c) If the modified program normally reads commands interactively when
run, you must cause it, when started running for such interactive use
in the simplest and most usual way, to print or display an
announcement including an appropriate copyright notice and a notice
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
the other work under the scope of these terms.
3. You may copy and distribute the Program (or a portion or derivative of
it, under Paragraph 2) in object code or executable form under the terms of
Paragraphs 1 and 2 above provided that you also do one of the following:
a) accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of
Paragraphs 1 and 2 above; or,
b) accompany it with a written offer, valid for at least three
years, to give any third party free (except for a nominal charge
for the cost of distribution) a complete machine-readable copy of the
corresponding source code, to be distributed under the terms of
Paragraphs 1 and 2 above; or,
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
accompany that operating system.
4. You may not copy, modify, sublicense, distribute or transfer the
Program except as expressly provided under this General Public License.
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
the Program is void, and will automatically terminate your rights to use
the Program under this License. However, parties who have received
copies, or rights to use copies, from you under this General Public
License will not have their licenses terminated so long as such parties
remain in full compliance.
5. By copying, distributing or modifying the Program (or any work based
on the Program) you indicate your acceptance of this license to do so,
and all its terms and conditions.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the original
licensor to copy, distribute or modify the Program subject to these
terms and conditions. You may not impose any further restrictions on the
recipients' exercise of the rights granted herein.
7. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of the license which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
the license, you may choose any version ever published by the Free Software
Foundation.
8. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to humanity, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. It is safest to
attach them to the start of each source file to most effectively convey
the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) 19yy <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) 19xx name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the
appropriate parts of the General Public License. Of course, the
commands you use may be called something other than `show w' and `show
c'; they could even be mouse-clicks or menu items--whatever suits your
program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
program `Gnomovision' (a program to direct compilers to make passes
at assemblers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
That's all there is to it!
--- The Artistic License 1.0 ---
This software is Copyright (c) 2019 by mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>.
This is free software, licensed under:
The Artistic License 1.0
The Artistic License
Preamble
The intent of this document is to state the conditions under which a Package
may be copied, such that the Copyright Holder maintains some semblance of
artistic control over the development of the package, while giving the users of
the package the right to use and distribute the Package in a more-or-less
customary fashion, plus the right to make reasonable modifications.
Definitions:
- "Package" refers to the collection of files distributed by the Copyright
Holder, and derivatives of that collection of files created through
textual modification.
- "Standard Version" refers to such a Package if it has not been modified,
or has been modified in accordance with the wishes of the Copyright
Holder.
- "Copyright Holder" is whoever is named in the copyright or copyrights for
the package.
- "You" is you, if you're thinking about copying or distributing this Package.
- "Reasonable copying fee" is whatever you can justify on the basis of media
cost, duplication charges, time of people involved, and so on. (You will
not be required to justify it to the Copyright Holder, but only to the
computing community at large as a market that must bear the fee.)
- "Freely Available" means that no fee is charged for the item itself, though
there may be fees involved in handling the item. It also means that
recipients of the item may redistribute it under the same conditions they
received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications derived
from the Public Domain or from the Copyright Holder. A Package modified in such
a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided that
you insert a prominent notice in each changed file stating how and when you
changed that file, and provided that you do at least ONE of the following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or an
equivalent medium, or placing the modifications on a major archive site
such as ftp.uu.net, or by allowing the Copyright Holder to include your
modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict with
standard executables, which must also be provided, and provide a separate
manual page for each non-standard executable that clearly documents how it
differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or executable
form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where to
get the Standard Version.
b) accompany the distribution with the machine-readable source of the Package
with your modifications.
c) accompany any non-standard executables with their corresponding Standard
Version executables, giving the non-standard executables non-standard
names, and clearly documenting the differences in manual pages (or
equivalent), together with instructions on where to get the Standard
Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this Package. You
may not charge a fee for this Package itself. However, you may distribute this
Package in aggregate with other (possibly commercial) programs as part of a
larger (possibly commercial) software distribution provided that you do not
advertise this Package as a product of your own.
6. The scripts and library files supplied as input to or produced as output
from the programs of this Package do not automatically fall under the copyright
of this Package, but belong to whomever generated them, and may be sold
commercially, and may be aggregated with this Package.
7. C or perl subroutines supplied by you and linked into this Package shall not
be considered part of this Package.
8. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End

149
MANIFEST Normal file
View File

@ -0,0 +1,149 @@
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/modifiers.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-Sub-Name.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/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
xt/zzz-prereq-versions.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)
LICENSE LICENSE file (added by Distar)

107
META.json Normal file
View File

@ -0,0 +1,107 @@
{
"abstract" : "Minimalist Object Orientation (with Moose compatibility)",
"author" : [
"mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.38, 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" : "1.15",
"MooseX::Types::Common::Numeric" : "0",
"Mouse" : "0",
"Type::Tiny" : "0.004",
"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.10",
"Exporter" : "5.57",
"Module::Runtime" : "0.014",
"Role::Tiny" : "2.001004",
"Scalar::Util" : "1.09",
"Sub::Defer" : "2.006006",
"Sub::Quote" : "2.006006",
"perl" : "5.006"
}
},
"test" : {
"recommends" : {
"CPAN::Meta::Requirements" : "0",
"Parse::CPAN::Meta" : "1.4200"
},
"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" : [
"https://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.003006",
"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 4.04"
}

52
META.yml Normal file
View File

@ -0,0 +1,52 @@
---
abstract: 'Minimalist Object Orientation (with Moose compatibility)'
author:
- 'mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>'
build_requires:
Test::Fatal: '0.003'
Test::More: '0.94'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.38, 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.10'
Exporter: '5.57'
Module::Runtime: '0.014'
Role::Tiny: '2.001004'
Scalar::Util: '1.09'
Sub::Defer: '2.006006'
Sub::Quote: '2.006006'
perl: '5.006'
resources:
IRC: irc://irc.perl.org/#moose
bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Moo
license: https://dev.perl.org/licenses/
repository: https://github.com/moose/Moo.git
version: '2.003006'
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'

177
Makefile.PL Normal file
View File

@ -0,0 +1,177 @@
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 => {
'Parse::CPAN::Meta' => '1.4200',
'CPAN::Meta::Requirements' => 0,
},
},
runtime => {
requires => {
'Class::Method::Modifiers' => '1.10', # for RT#80194
'Module::Runtime' => '0.014', # for RT#86394
'Role::Tiny' => '2.001004',
'Scalar::Util' => '1.09',
'perl' => '5.006',
'Exporter' => '5.57', # Import 'import'
'Sub::Quote' => '2.006006',
'Sub::Defer' => '2.006006',
},
recommends => {
'Class::XSAccessor' => '1.18',
'Sub::Name' => '0.08',
'strictures' => '2',
},
},
develop => {
requires => {
'strictures' => '2',
'bareword::filehandles' => 0,
'indirect' => 0,
'multidimensional' => 0,
'Class::Tiny' => '1.001',
'Moose' => '1.15',
'MooseX::Types::Common::Numeric' => 0,
'Mouse' => 0,
'namespace::autoclean' => 0,
'namespace::clean' => 0,
'Type::Tiny' => '0.004',
},
},
},
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 => [ 'https://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 $xt = $ENV{EXTENDED_TESTING};
my %MM_ARGS = (
PREREQ_PM => {
("$]" >= 5.008_000 ? () : ('Task::Weaken' => 0)),
("$]" >= 5.010_000 ? () : ('MRO::Compat' => 0)),
("$]" >= 5.014_000 ? () : ('Devel::GlobalDestruction' => 0.11)),
},
($xt ? (
TEST_REQUIRES => {
%{ $META{prereqs}{runtime}{recommends} },
%{ $META{prereqs}{test}{recommends} },
%{ $META{prereqs}{develop}{requires} },
},
test => { TESTS => 't/*.t xt/*.t' },
):()),
);
{
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' || $xt) ? "MOO_FATAL_WARNINGS" : '';
($xt ? <<"XT" : '')
test :: test_no_xs
XT
.<<"POSTAMBLE"
MOO_TEST_ENV=$MOO_TEST_ENV
fulltest: test test_no_xs
\t\$(NOECHO) \$(NOOP)
test_no_xs: \$(TEST_TYPE)_no_xs
\t\$(NOECHO) \$(NOOP)
POSTAMBLE
.join('', map <<"TEST_TYPE", 'dynamic', 'static', '')
test_${_}_no_xs: pure_all
\t\$(NOECHO)\$(MAKE) test_$_ MOO_TEST_ENV="\$(MOO_TEST_ENV),MOO_XS_DISABLE"
TEST_TYPE
}
}
## 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 ###########################################################

788
README Normal file
View File

@ -0,0 +1,788 @@
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. As such, the Moose::Manual can
serve as an effective guide to "Moo" aside from the MOP and Types
sections.
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
<https://shadow.cat/blog/matt-s-trout/moo-versus-any-moose> 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;
For example if you were to import these subroutines after
namespace::clean like this
use namespace::clean;
use Digest::MD5 qw(md5_hex);
use Moo;
then any "Record" $r would have methods such as "$r->md5_hex()",
"$r->has()" and "$r->around()" - almost certainly not what you intend!
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
TYPES
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);
API INCOMPATIBILITIES
"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.
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;
META OBJECT
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.
IMMUTABILITY
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
IRC: #moose on irc.perl.org
Bugtracker: <https://rt.cpan.org/Public/Dist/Display.html?Name=Moo>
Git repository: <git://github.com/moose/Moo.git>
Git browser: <https://github.com/moose/Moo>
AUTHOR
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
CONTRIBUTORS
dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org>
jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com>
ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org>
doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net>
perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org>
Mithaldu - Christian Walde (cpan:MITHALDU)
<walde.christian@googlemail.com>
ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
mattp - Matt Phillips (cpan:MATTP) <mattp@cpan.org>
bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
bubaflub - Bob Kuo (cpan:BUBAFLUB) <bubaflub@cpan.org>
ether = Karen Etheridge (cpan:ETHER) <ether@cpan.org>
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 <https://dev.perl.org/licenses/>.

700
lib/Method/Generate/Accessor.pm Normal file
View File

@ -0,0 +1,700 @@
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 ($key eq 'builder' || $key eq 'default') {
$spec->{$key} = $old_spec->{$key}
if !(exists $spec->{builder} || exists $spec->{default});
}
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;

42
lib/Method/Generate/BuildAll.pm Normal file
View File

@ -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;

266
lib/Method/Generate/Constructor.pm Normal file
View File

@ -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;

65
lib/Method/Generate/DemolishAll.pm Normal file
View File

@ -0,0 +1,65 @@
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;
BEGIN {
*_USE_DGD = "$]" < 5.014 ? sub(){1} : sub(){0};
require Devel::GlobalDestruction
if _USE_DGD();
}
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 $@;!.(_USE_DGD ? q!
require Devel::GlobalDestruction;! : '').q!
package !.$into.q!;
eval {
$self->DEMOLISHALL(!.(
_USE_DGD
? 'Devel::GlobalDestruction::in_global_destruction()'
: q[${^GLOBAL_PHASE} eq 'DESTRUCT']
).q!);
};
$@;
};
# 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 '',
qq{ package $into;\n},
map qq{ ${me}->${_}(${args});\n}, @demolishers;
}
sub _handle_subdemolish {
my ($self, $into) = @_;
' if (ref($_[0]) ne '.quotify($into).') {'."\n".
" package $into;\n".
' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
' }'."\n";
}
1;

1105
lib/Moo.pm Normal file
View File

File diff suppressed because it is too large Load Diff

228
lib/Moo/HandleMoose.pm Normal file
View File

@ -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;

41
lib/Moo/HandleMoose/FakeMetaClass.pm Normal file
View File

@ -0,0 +1,41 @@
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;
# prevent inflation by Devel::StackTrace, which does this check. examining
# the stack trace in an exception from inflation could re-trigger inflation
# and cause another exception.
return !!0
if @_ == 1 && $_[0] eq 'Exception::Class::Base';
require Moo::HandleMoose;
Moo::HandleMoose::inject_real_metaclass_for($self->{name})->isa(@_)
}
sub make_immutable { $_[0] }
1;

76
lib/Moo/HandleMoose/_TypeMap.pm Normal file
View File

@ -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;

77
lib/Moo/Object.pm Normal file
View File

@ -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;

566
lib/Moo/Role.pm Normal file
View File

@ -0,0 +1,566 @@
package Moo::Role;
use Moo::_strictures;
use Moo::_Utils qw(
_check_tracked
_getglob
_getstash
_install_coderef
_install_modifier
_install_tracked
_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.003006';
$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 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 _accessor_maker_for {
my ($class, $target) = @_;
($INFO{$target}{accessor_maker} ||= do {
require Method::Generate::Accessor;
Method::Generate::Accessor->new
});
}
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;
$me->_accessor_maker_for($target)
->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);
}
sub _maybe_reset_handlemoose {
my ($class, $target) = @_;
if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) {
Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
}
}
sub _non_methods {
my $self = shift;
my ($role) = @_;
my $non_methods = $self->SUPER::_non_methods(@_);
my $all_subs = $self->_all_subs($role);
$non_methods->{$_} = $all_subs->{$_}
for _check_tracked($role, [ keys %$all_subs ]);
return $non_methods;
}
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<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
documentation on how this works (in particular, using C<Moo::Role> also
enables L<strict> and L<warnings>). The main addition here is extra bits to
make the roles more "Moosey;" which is to say, it adds L</has>.
=head1 IMPORTED SUBROUTINES
See L<Role::Tiny/IMPORTED SUBROUTINES> 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<Moo/has> for all options.
=head1 CLEANING UP IMPORTS
L<Moo::Role> cleans up its own imported methods and any imports
declared before the C<use Moo::Role> statement automatically.
Anything imported after C<use Moo::Role> 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<Can't locate object method "md5_hex">.
See L<Moo/"CLEANING UP IMPORTS"> for more details.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut

189
lib/Moo/_Utils.pm Normal file
View File

@ -0,0 +1,189 @@
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 Exporter qw(import);
use Config;
use Scalar::Util qw(weaken);
use Carp qw(croak);
# this should be empty, but some CPAN modules expect these
our @EXPORT = qw(
_install_coderef
_load_module
);
our @EXPORT_OK = qw(
_check_tracked
_getglob
_getstash
_install_coderef
_install_modifier
_install_tracked
_load_module
_maybe_load_module
_name_coderef
_set_loaded
_unimport_coderefs
);
my %EXPORTS;
sub _install_modifier {
my $target = $_[0];
my $type = $_[1];
my $code = $_[-1];
my @names = @_[2 .. $#_ - 1];
@names = @{ $names[0] }
if ref($names[0]) eq 'ARRAY';
my @tracked = _check_tracked($target, \@names);
if ($INC{'Sub/Defer.pm'}) {
for my $name (@names) {
# CMM will throw for us if it doesn't exist
if (my $to_modify = $target->can($name)) {
Sub::Defer::undefer_sub($to_modify);
}
}
}
require Class::Method::Modifiers;
Class::Method::Modifiers::install_modifier(@_);
if (@tracked) {
my $exports = $EXPORTS{$target};
weaken($exports->{$_} = $target->can($_))
for @tracked;
}
return;
}
sub _install_tracked {
my ($target, $name, $code) = @_;
my $from = caller;
weaken($EXPORTS{$target}{$name} = $code);
_install_coderef("${target}::${name}", "${from}::${name}", $code);
}
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 _check_tracked {
my ($target, $names) = @_;
my $stash = _getstash($target);
my $exports = $EXPORTS{$target}
or return;
$names = [keys %$exports]
if !$names;
my %rev =
map +($exports->{$_} => $_),
grep defined $exports->{$_},
keys %$exports;
return
grep {
my $g = $stash->{$_};
$g && defined &$g && exists $rev{\&$g};
}
@$names;
}
sub _unimport_coderefs {
my ($target) = @_;
my $stash = _getstash($target);
my @exports = _check_tracked($target);
foreach my $name (@exports) {
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;

10
lib/Moo/_mro.pm Normal file
View File

@ -0,0 +1,10 @@
package Moo::_mro;
use Moo::_strictures;
if ("$]" >= 5.010_000) {
require mro;
} else {
require MRO::Compat;
}
1;

19
lib/Moo/_strictures.pm Normal file
View File

@ -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;

42
lib/Moo/sification.pm Normal file
View File

@ -0,0 +1,42 @@
package Moo::sification;
use Moo::_strictures;
no warnings 'once';
BEGIN {
*_USE_DGD = "$]" < 5.014 ? sub(){1} : sub(){0};
require Devel::GlobalDestruction
if _USE_DGD();
}
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
_USE_DGD
? Devel::GlobalDestruction::in_global_destruction()
: ${^GLOBAL_PHASE} eq 'DESTRUCT'
) {
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;

65
lib/oo.pm Normal file
View File

@ -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<package $name; use Moo;> to the
beginning of your script, intended for use on the command line via the -M
option.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut

12
maint/Makefile.PL.include Normal file
View File

@ -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) <mst@shadowcat.co.uk>';
manifest_include t => 'global-destruction-helper.pl';
manifest_include xt => 'global-destruct-jenga-helper.pl';
1;

216
t/accessor-coerce.t Normal file
View File

@ -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;

109
t/accessor-default.t Normal file
View File

@ -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;

159
t/accessor-generator-extension.t Normal file
View File

@ -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;

129
t/accessor-handles.t Normal file
View File

@ -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;

238
t/accessor-isa.t Normal file
View File

@ -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;

81
t/accessor-mixed.t Normal file
View File

@ -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;

32
t/accessor-pred-clear.t Normal file
View File

@ -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;

80
t/accessor-reader-writer.t Normal file
View File

@ -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;

56
t/accessor-roles.t Normal file
View File

@ -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;

43
t/accessor-shortcuts.t Normal file
View File

@ -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;

149
t/accessor-trigger.t Normal file
View File

@ -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;

12
t/accessor-weaken-pre-5_8_3.t Normal file
View File

@ -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 $!;
}

77
t/accessor-weaken.t Normal file
View File

@ -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;

88
t/buildall-subconstructor.t Normal file
View File

@ -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;

94
t/buildall.t Normal file
View File

@ -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;

25
t/buildargs-error.t Normal file
View File

@ -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;

154
t/buildargs.t Normal file
View File

@ -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;

92
t/coerce-1.t Normal file
View File

@ -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;

179
t/compose-conflicts.t Normal file
View File

@ -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;

14
t/compose-non-role.t Normal file
View File

@ -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;

173
t/compose-roles.t Normal file
View File

@ -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;

139
t/constructor-modify.t Normal file
View File

@ -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;

283
t/croak-locations.t Normal file
View File

@ -0,0 +1,283 @@
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
location_ok <<'END_CODE', 'Method::Generate::DemolishAll - user croak';
use Carp qw(croak);
use Moo;
sub DEMOLISH {
croak "demolish" unless $_[0]->{demolished}++;
}
my $o = $PACKAGE->new;
package Elsewhere;
# object destruction normally can't throw, so run this manually
$o->DESTROY;
END_CODE
done_testing;

51
t/demolish-basics.t Normal file
View File

@ -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;

139
t/demolish-bugs-eats_exceptions.t Normal file
View File

@ -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;

75
t/demolish-bugs-eats_mini.t Normal file
View File

@ -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;

28
t/demolish-global_destruction.t Normal file
View File

@ -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;

54
t/demolish-throw.t Normal file
View File

@ -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;

47
t/does.t Normal file
View File

@ -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;

29
t/extend-constructor.t Normal file
View File

@ -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;

83
t/extends-non-moo.t Normal file
View File

@ -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();

15
t/extends-role.t Normal file
View File

@ -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;

53
t/foreignbuildargs.t Normal file
View File

@ -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;

18
t/global-destruction-helper.pl Normal file
View File

@ -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;

44
t/global_underscore.t Normal file
View File

@ -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;

44
t/has-array.t Normal file
View File

@ -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;

25
t/has-before-extends.t Normal file
View File

@ -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;

117
t/has-plus.t Normal file
View File

@ -0,0 +1,117 @@
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';
{
package HasDefault;
use Moo;
has guff => (is => 'ro', default => sub { 'guff' });
}
{
package ExtendsWithBuilder;
use Moo;
extends 'HasDefault';
has '+guff' => (builder => sub { 'welp' });
}
is +ExtendsWithBuilder->new->guff, 'welp',
'builder can override default';
done_testing;

108
t/init-arg.t Normal file
View File

@ -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;

61
t/isa-interfere.t Normal file
View File

@ -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;

75
t/lazy_isa.t Normal file
View File

@ -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;

82
t/lib/ErrorLocation.pm Normal file
View File

@ -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;

51
t/lib/InlineModule.pm Normal file
View File

@ -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;

10
t/lib/TestEnv.pm Normal file
View File

@ -0,0 +1,10 @@
package TestEnv;
use strict;
use warnings;
sub import {
$ENV{$_} = 1
for grep defined && length && !exists $ENV{$_}, @_[1 .. $#_];
}
1;

21
t/load_module.t Normal file
View File

@ -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;

23
t/load_module_error.t Normal file
View File

@ -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;

21
t/load_module_role_tiny.t Normal file
View File

@ -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;

51
t/long-package-name.t Normal file
View File

@ -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;

211
t/method-generate-accessor.t Normal file
View File

@ -0,0 +1,211 @@
use Moo::_strictures;
use Test::More;
use Test::Fatal;
use Method::Generate::Accessor;
use Sub::Quote 'quote_sub';
use Sub::Defer ();
my $gen;
BEGIN {
$gen = Method::Generate::Accessor->new;
}
{
package Foo;
use Moo;
}
BEGIN {
# lie about overload.pm just in case
local $INC{'overload.pm'};
delete $INC{'overload.pm'};
my $c = bless {}, 'Gorf';
like(
exception { $gen->generate_method('Foo' => 'gorf' => { is => 'ro', coerce => $c } ) },
qr/^Invalid coerce '\Q$c\E' for Foo->gorf /, "coerce - object rejected (before overload loaded)"
);
}
{
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;

96
t/method-generate-constructor.t Normal file
View File

@ -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;

42
t/modifiers.t Normal file
View File

@ -0,0 +1,42 @@
use Moo::_strictures;
use Test::More;
{
package SomeObject;
use Moo;
use Sub::Defer qw(defer_sub);
my $gen = 0;
defer_sub 'SomeObject::deferred_sub' => sub {
$gen++;
sub { 1 };
};
after deferred_sub => sub {
1;
};
::is $gen, 1,
'applying modifier undefers subs';
my $gen_multi = 0;
defer_sub 'SomeObject::deferred_sub_guff' => sub {
$gen_multi++;
sub { 1 };
};
defer_sub 'SomeObject::deferred_sub_wark' => sub {
$gen_multi++;
sub { 1 };
};
after [qw(deferred_sub_guff deferred_sub_wark)] => sub {
1;
};
::is $gen_multi, 2,
'applying modifier to multiple subs undefers';
}
done_testing;

53
t/modify_lazy_handlers.t Normal file
View File

@ -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;

61
t/moo-accessors.t Normal file
View File

@ -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;

37
t/moo-c3.t Normal file
View File

@ -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;

55
t/moo-object.t Normal file
View File

@ -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;

20
t/moo-utils-_name_coderef.t Normal file
View File

@ -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;

27
t/moo-utils-_subname-Sub-Name.t Normal file
View File

@ -0,0 +1,27 @@
use Moo::_strictures;
use lib 't/lib';
use InlineModule
'Sub::Name' => <<'END_SN',
package Sub::Name;
use strict;
use warnings;
sub subname {
$::sub_name_run++;
return $_[1];
}
1;
END_SN
'Sub::Util' => undef,
;
use Test::More;
use Moo::_Utils ();
$::sub_name_run = 0;
my $sub = Moo::_Utils::_subname 'Some::Sub', sub { 5 };
is $sub->(), 5, '_subname runs with Sub::Name';
is $::sub_name_run, 1, '_subname uses Sub::Name::subname';
done_testing;

14
t/moo-utils-_subname.t Normal file
View File

@ -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;

85
t/moo-utils.t Normal file
View File

@ -0,0 +1,85 @@
use Moo::_strictures;
use Test::More;
use Test::Fatal;
use Moo::_Utils qw(
_maybe_load_module
);
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;

106
t/moo.t Normal file
View File

@ -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;

44
t/mutual-requires.t Normal file
View File

@ -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;

66
t/no-build.t Normal file
View File

@ -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;

124
t/no-moo.t Normal file
View File

@ -0,0 +1,124 @@
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');
{
package WrappedHas;
use Moo;
BEGIN {
after has => sub {
1;
};
}
has welp => (is => 'ro');
no Moo;
}
is +WrappedHas->can('has'), undef,
'has with modifier applied is cleaned';
done_testing;

62
t/non-moo-extends-c3.t Normal file
View File

@ -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;

110
t/non-moo-extends.t Normal file
View File

@ -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;

44
t/not-both.t Normal file
View File

@ -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;

86
t/not-methods.t Normal file
View File

@ -0,0 +1,86 @@
use Moo::_strictures;
use Test::More;
BEGIN {
package FooClass;
sub early { 1 }
sub early_constant { 2 }
use Moo;
sub late { 2 }
sub late_constant { 2 }
}
BEGIN {
is_deeply
[sort keys %{Moo->_concrete_methods_of('FooClass')}],
[qw(late late_constant)],
'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';
}
SKIP: {
skip 'code refs directly in the stash not stable until perl 5.26.1', 1
unless "$]" >= 5.026001;
eval '#line '.(__LINE__).' "'.__FILE__.qq["\n].q{
package Gwaf;
BEGIN { $Gwaf::{foo} = sub { 'foo' }; }
use constant plorp => 1;
use Moo;
BEGIN { $Gwaf::{frab} = sub { 'frab' }; }
use constant terg => 1;
1;
} or die $@;
is_deeply
[sort keys %{Moo->_concrete_methods_of('Gwaf')}],
[qw(frab terg)],
'subrefs stored directly in stash treated the same as those with globs';
}
done_testing;

75
t/overloaded-coderefs.t Normal file
View File

@ -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;

79
t/overridden-core-funcs.t Normal file
View File

@ -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;

36
t/strictures.t Normal file
View File

@ -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;

84
t/sub-and-handles.t Normal file
View File

@ -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;

18
t/subconstructor.t Normal file
View File

@ -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;

13
t/undef-bug.t Normal file
View File

@ -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";

40
t/use-after-no.t Normal file
View File

@ -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;

56
t/zzz-check-breaks.t Normal file
View File

@ -0,0 +1,56 @@
use strict;
use warnings;
use Test::More;
my $meta;
BEGIN {
eval { require Parse::CPAN::Meta; Parse::CPAN::Meta->VERSION(1.4200) }
or plan skip_all => 'Parse::CPAN::Meta required for checking breakages';
eval { require CPAN::Meta::Requirements }
or plan skip_all => 'CPAN::Meta::Requirements required for checking breakages';
my @meta_files = grep -f, qw(MYMETA.json MYMETA.yml META.json META.yml)
or plan skip_all => 'no META file exists';
for my $meta_file (@meta_files) {
eval { $meta = Parse::CPAN::Meta->load_file($meta_file) }
and last;
}
if (!$meta) {
plan skip_all => 'unable to load any META files';
}
}
use ExtUtils::MakeMaker;
my $breaks = $meta->{x_breaks};
my $req = CPAN::Meta::Requirements->from_string_hash( $breaks );
pass 'checking breakages...';
my @breaks;
for my $module ($req->required_modules) {
(my $file = "$module.pm") =~ s{::}{/}g;
my ($pm_file) = grep -e, map "$_/$file", @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 = $breaks->{$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;

21
xt/bless-override.t Normal file
View File

@ -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;

28
xt/class-tiny.t Normal file
View File

@ -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;

Some files were not shown because too many files have changed in this diff Show More