Moo-1.004002/000755 000765 000024 00000000000 12260624267 012762 5ustar00gknopstaff000000 000000 Moo-1.004002/bin/000755 000765 000024 00000000000 12260624267 013532 5ustar00gknopstaff000000 000000 Moo-1.004002/Changes000644 000765 000024 00000033173 12260624140 014252 0ustar00gknopstaff000000 000000 Revision history for Moo 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 Moo-1.004002/lib/000755 000765 000024 00000000000 12260624267 013530 5ustar00gknopstaff000000 000000 Moo-1.004002/maint/000755 000765 000024 00000000000 12260624267 014072 5ustar00gknopstaff000000 000000 Moo-1.004002/Makefile.PL000644 000765 000024 00000010432 12260306270 014723 0ustar00gknopstaff000000 000000 use strict; use warnings FATAL => 'all'; use 5.008001; use ExtUtils::MakeMaker; check_conflicts(); (do 'maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; my %META = ( name => 'Moo', license => 'perl_5', prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, 'Dist::CheckConflicts' => '0.02', } }, build => { requires => { } }, test => { requires => { 'Test::More' => 0.94, 'Test::Fatal' => 0.003, } }, runtime => { requires => { 'perl' => 5.008001, 'Class::Method::Modifiers' => 1.10, # for RT#80194 'strictures' => 1.004003, 'Module::Runtime' => 0.012, # for RT#74789 'Role::Tiny' => 1.003002, 'Devel::GlobalDestruction' => 0.11, # for RT#78617 'Dist::CheckConflicts' => 0.02, 'Import::Into' => 1.002, ($] >= 5.010 ? () : ('MRO::Compat' => 0)), } }, develop => { requires => { map { $_ => 0 } qw( Class::XSAccessor indirect multidimensional bareword::filehandles ) }, recommends => { map { $_ => 0 } qw( Moose Mouse namespace::clean namespace::autoclean MooseX::Types::Common::Numeric Type::Tiny ) }, }, }, resources => { repository => { url => 'https://github.com/moose/Moo.git', web => 'https://github.com/moose/Moo', type => 'git', }, x_IRC => 'irc://irc.perl.org/#moose', bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Moo', mailto => 'bug-Moo@rt.cpan.org', }, license => [ 'http://dev.perl.org/licenses/' ], }, no_index => { directory => [ 't', 'xt' ] }, Moo::Conflicts->can('conflicts') ? ( x_breaks => { Moo::Conflicts->conflicts } ) : (), ); my %MM_ARGS = ( EXE_FILES => [ 'bin/moo-outdated', ], ); # have to do this since old EUMM dev releases miss the eval $VERSION line my $mmver = eval $ExtUtils::MakeMaker::VERSION; my $mymeta_works = $mmver >= 6.57_07; my $mymeta = $mmver >= 6.57_02; my $has_test_requires = $mmver >= 6.63_03; my %configure_deps = %{$META{prereqs}{configure}{requires}}; my %build_deps = %{$META{prereqs}{build}{requires}}; my %test_deps = %{$META{prereqs}{test}{requires}}; my %run_deps = %{$META{prereqs}{runtime}{requires}}; my $min_perl_version = delete $run_deps{perl}; if (not $has_test_requires) { %build_deps = (%build_deps, %test_deps); %test_deps = (); } if (not $mymeta_works) { %run_deps = (%run_deps, %build_deps); %build_deps = (); } # $META{name} is the dist name, EUMM needs the module name and file (my $module_name = $META{name}) =~ s/-/::/g; (my $module_file = "lib/$module_name.pm") =~ s{::}{/}g; WriteMakefile( NAME => $module_name, VERSION_FROM => $module_file, LICENSE => $META{license}, $min_perl_version ? ( MIN_PERL_VERSION => $min_perl_version ) : (), keys %configure_deps ? ( CONFIGURE_REQUIRES => \%configure_deps ) : (), keys %build_deps ? ( BUILD_REQUIRES => \%build_deps ) : (), keys %test_deps ? ( TEST_REQUIRES => \%test_deps ) : (), keys %run_deps ? ( PREREQ_PM => \%run_deps ) : (), ($mymeta && !$mymeta_works ? (NO_MYMETA => 1) : ()), -f 'META.yml' ? () : (META_ADD => { 'meta-spec' => { version => 2 }, %META }), %MM_ARGS, ); # copied from Moose-2.0801/Makefile.PL sub check_conflicts { if ( eval { require 'lib/Moo/Conflicts.pm'; 1; } ) { if ( eval { Moo::Conflicts->check_conflicts; 1 } ) { return; } else { my $err = $@; $err =~ s/^/ /mg; warn "***\n$err***\n"; } } else { print <<'EOF'; *** Your toolchain doesn't support configure_requires, so Dist::CheckConflicts hasn't been installed yet. You should check for conflicting modules manually using the 'moo-outdated' script that is installed with this distribution once the installation finishes. *** EOF } return if $ENV{AUTOMATED_TESTING} || $ENV{NONINTERACTIVE_TESTING}; # More or less copied from Module::Build return if $ENV{PERL_MM_USE_DEFAULT}; return unless -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); return unless -f 'META.yml'; sleep 4; } Moo-1.004002/MANIFEST000644 000765 000024 00000006300 12260624267 014112 0ustar00gknopstaff000000 000000 bin/moo-outdated Changes lib/Method/Generate/Accessor.pm lib/Method/Generate/BuildAll.pm lib/Method/Generate/Constructor.pm lib/Method/Generate/DemolishAll.pm lib/Method/Inliner.pm lib/Moo.pm lib/Moo/_mro.pm lib/Moo/_Utils.pm lib/Moo/Conflicts.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 lib/Sub/Defer.pm lib/Sub/Quote.pm maint/bump-version maint/fulltest maint/Makefile.PL.include maint/travis-install maint/travis-perlbrew 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/compose-non-role.t t/compose-roles.t t/demolish-basics.t t/demolish-bugs-eats_exceptions.t t/demolish-bugs-eats_mini.t t/demolish-global_destruction.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/lazy_isa.t t/lib/base_class.pm t/lib/ClassicObject.pm t/lib/ClobberUnderscore.pm t/lib/ComplexWriter.pm t/lib/ExtRobot.pm t/lib/MooObjectWithDelegate.pm t/lib/sub_class.pm t/lib/UnderscoreClass.pm t/lib/UnderscoreRole.pm t/load_module.t t/load_module_error.t t/load_module_role_tiny.t t/method-generate-accessor.t t/method-generate-constructor.t t/modify_lazy_handlers.t t/moo-accessors.t t/moo.t t/mutual-requires.t t/no-moo.t t/non-moo-extends.t t/not-both.t t/overloaded-coderefs.t t/sub-and-handles.t t/sub-defer-threads.t t/sub-defer.t t/sub-quote-threads.t t/sub-quote.t t/subconstructor.t t/undef-bug.t t/use-after-no.t xt/global-destruct-jenga.t xt/handle_moose.t xt/implicit-moose-types.t xt/jenga.t xt/lib/ExampleMooRole.pm xt/lib/ExampleMooRoleWithAttribute.pm xt/lib/ExampleMooseRoleOne.pm xt/lib/ExampleMooseRoleTwo.pm xt/lib/withautoclean/Class.pm xt/lib/withautoclean/R1.pm 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-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.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-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/strictures.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/withautoclean.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Moo-1.004002/META.json000644 000765 000024 00000004417 12260624267 014411 0ustar00gknopstaff000000 000000 { "abstract" : "Minimalist Object Orientation (with Moose compatibility)", "author" : [ "mst - Matt S. Trout (cpan:MSTROUT) " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.82, CPAN::Meta::Converter version 2.132830", "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" : { "Dist::CheckConflicts" : "0.02", "ExtUtils::MakeMaker" : "0" } }, "develop" : { "recommends" : { "Moose" : "0", "MooseX::Types::Common::Numeric" : "0", "Mouse" : "0", "Type::Tiny" : "0", "namespace::autoclean" : "0", "namespace::clean" : "0" }, "requires" : { "Class::XSAccessor" : "0", "bareword::filehandles" : "0", "indirect" : "0", "multidimensional" : "0" } }, "runtime" : { "requires" : { "Class::Method::Modifiers" : "1.1", "Devel::GlobalDestruction" : "0.11", "Dist::CheckConflicts" : "0.02", "Import::Into" : "1.002", "Module::Runtime" : "0.012", "Role::Tiny" : "1.003002", "perl" : "5.008001", "strictures" : "1.004003" } }, "test" : { "requires" : { "Test::Fatal" : "0.003", "Test::More" : "0.94" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Moo@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Moo" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/moose/Moo.git", "web" : "https://github.com/moose/Moo" }, "x_IRC" : "irc://irc.perl.org/#moose" }, "version" : "1.004002", "x_breaks" : { "HTML::Restrict" : "2.1.5" } } Moo-1.004002/META.yml000644 000765 000024 00000001750 12260624267 014236 0ustar00gknopstaff000000 000000 --- abstract: 'Minimalist Object Orientation (with Moose compatibility)' author: - 'mst - Matt S. Trout (cpan:MSTROUT) ' build_requires: Test::Fatal: 0.003 Test::More: 0.94 configure_requires: Dist::CheckConflicts: 0.02 ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.82, CPAN::Meta::Converter version 2.132830' 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 requires: Class::Method::Modifiers: 1.1 Devel::GlobalDestruction: 0.11 Dist::CheckConflicts: 0.02 Import::Into: 1.002 Module::Runtime: 0.012 Role::Tiny: 1.003002 perl: 5.008001 strictures: 1.004003 resources: IRC: irc://irc.perl.org/#moose bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Moo license: http://dev.perl.org/licenses/ repository: https://github.com/moose/Moo.git version: 1.004002 x_breaks: HTML::Restrict: 2.1.5 Moo-1.004002/README000644 000765 000024 00000060450 12260624267 013647 0ustar00gknopstaff000000 000000 NAME Moo - Minimalist Object Orientation (with Moose compatibility) SYNOPSIS package Cat::Food; use Moo; 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 This module is an extremely light-weight subset of Moose optimised for rapid startup and "pay only for what you use". It also avoids depending on any XS modules to allow simple deployments. The name "Moo" is based on the idea that it provides almost -- but not quite -- two thirds of Moose. Unlike Mouse this module does not aim at full compatibility with Moose's surface syntax, preferring instead of 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. However, sometimes you're writing a command line script or a CGI script where fast startup is essential, or code designed to be deployed as a single file via App::FatPacker, or you're writing a CPAN module and you want it to be usable by people with those constraints. I've tried several times to use Mouse but it's 3x the size of Moo and takes longer to load than most of my Moo based CGI scripts take to run. If you don't want Moose, you don't want "less metaprotocol" like Mouse, you want "as little as possible" -- which means "no metaprotocol", which is what Moo provides. Better still, if you install and load Moose, we set up metaclasses for your Moo classes and Moo::Role roles, so you can use them in Moose code without ever noticing that some of your codebase is using Moo. Hence, Moo exists as its name -- Minimal Object Orientation -- with a pledge to make it smooth to upgrade to Moose when you need more than minimal features. 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 anybody ever noticing you aren't using Moose everywhere. Moo will also create Moose type constraints for classes and roles, so that "isa => 'MyClass'" and "isa => 'MyRole'" work the same as for Moose classes and roles. Extending a Moose class or consuming a Moose::Role will also work. So will extending a Mouse class or consuming a Mouse::Role - 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 want types to be upgraded to the Moose types, use MooX::Types::MooseLike and install the MooseX::Types library to match the MooX::Types::MooseLike library you're using - Moo will load the MooseX::Types library and use that type for the newly created metaclass. 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 currently 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 a speed boost. Simple accessors are those without lazy defaults, type checks/coercions, or triggers. Readers and writers generated by Class::XSAccessor will behave slightly differently: they will reject attempts to call them with the incorrect number of parameters. MOO VERSUS ANY::MOOSE Any::Moose will load Mouse normally, and Moose in a program using Moose - which theoretically allows you to get the startup time of Mouse without disadvantaging Moose users. Sadly, this doesn't entirely work, since the selection is load order dependent - Moo's metaclass inflation system explained above in "MOO AND MOOSE" is significantly more reliable. So if you want to write a CPAN module that loads fast or has only pure perl dependencies but is also fully usable by Moose users, you should be using Moo. For a full explanation, see the article which explains the differing strategies in more detail and provides a direct example of where Moo succeeds and Any::Moose fails. IMPORTED METHODS new Foo::Bar->new( attr1 => 3 ); or Foo::Bar->new({ attr1 => 3 }); BUILDARGS sub BUILDARGS { my ( $class, @args ) = @_; unshift @args, "attr1" if @args % 2 == 1; return { @args }; }; Foo::Bar->new( 3 ); The default implementation of this method accepts a hash or hash reference of named parameters. If it receives a single argument that isn't a hash reference it throws an error. You can override this method in your class to handle other types of options passed to the constructor. This method should always return a hash reference of named options. FOREIGNBUILDARGS 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 Define a "BUILD" method on your class and the constructor will automatically call the "BUILD" method from parent down to child after the object has been instantiated. Typically this is used for object validation or possibly logging. DEMOLISH If you have a "DEMOLISH" method anywhere in your inheritance hierarchy, a "DESTROY" method is created on first object construction which will call "$instance->DEMOLISH($in_global_destruction)" for each "DEMOLISH" method from child upwards to parents. Note that the "DESTROY" method is created on first construction of an object of your class in order to not add overhead to classes without "DEMOLISH" methods; this may prove slightly surprising if you try and define your own. does if ($foo->does('Some::Role1')) { ... } Returns true if the object composes in the passed role. IMPORTED SUBROUTINES extends extends 'Parent::Class'; Declares base class. Multiple superclasses can be passed for multiple inheritance (but please use roles instead). The class will be loaded, however no errors will be triggered if it 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 have conflicting methods. The roles will be loaded using the same mechansim 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. The options for "has" are as follows: * is required, may be "ro", "lazy", "rwp" or "rw". "ro" 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" 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" generates a normal getter/setter by defaulting "accessor" to the name of the attribute. * isa Takes a coderef which is meant to validate the attribute. Unlike Moose, Moo does not include a basic type system, so instead of doing "isa => 'Num'", one should do isa => sub { die "$_[0] is not a number!" unless looks_like_number $_[0] }, Note that the return value is ignored, only whether the sub lives or dies matters. 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 MooseX::Types style named types, look at MooX::Types::MooseLike. 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 fire 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 * handles Takes a string handles => 'RobotRole' Where "RobotRole" is a role (Moo::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. 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 is supplied to the constructor - or if the attribute is lazy, 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. * "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 instantiation. * "reader" The value of this attribute will be the name of the method to get 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 are possible, which will cause leaks. * "init_arg" Takes the name of the key to look for at instantiation time of the object. A common use of this is to make an underscored attribute have a non-underscored initialization name. "undef" means that passing the value in on instantiation is ignored. * "moosify" Takes either a coderef or array of coderefs which is meant to transform the given attributes specifications if necessary when upgrading to a Moose role or class. You shouldn't need this by default, but is provided as a means of possible extensibility. before before foo => sub { ... }; See "before method(s) => sub { ... }" in Class::Method::Modifiers for full documentation. around around foo => sub { ... }; See "around method(s) => sub { ... }" in Class::Method::Modifiers for full documentation. after after foo => sub { ... }; See "after method(s) => sub { ... }" in Class::Method::Modifiers for full documentation. SUB QUOTE AWARE "quote_sub" in Sub::Quote allows us to create coderefs that are "inlineable," giving us a handy, XS-free speed boost. Any option that is Sub::Quote aware can take advantage of this. To do this, you can write use Sub::Quote; use Moo; use namespace::clean; has foo => ( is => 'ro', isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 }) ); which will be inlined as do { local @_ = ($_[0]->{foo}); die "Not <3" unless $_[0] < 3; } or to avoid localizing @_, has foo => ( is => 'ro', isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 }) ); which will be inlined as do { my ($val) = ($_[0]->{foo}); die "Not <3" unless $val < 3; } See Sub::Quote for more information, including how to pass lexical captures that will also be compiled into the subroutine. CLEANING UP IMPORTS Moo will not clean up imported subroutines for you; you will have to do that manually. The recommended way to do this is to declare your imports first, then "use Moo", then "use namespace::clean". Anything imported before namespace::clean will be scrubbed. Anything imported or declared after will be still be available. package Record; use Digest::MD5 qw(md5_hex); use Moo; use namespace::clean; has name => (is => 'ro', required => 1); has id => (is => 'lazy'); sub _build_id { my ($self) = @_; return md5_hex($self->name); } 1; If you were to import "md5_hex" after namespace::clean you would be able to call "->md5_hex()" on your "Record" instances (and it probably wouldn't do what you expect!). Moo::Roles behave slightly differently. Since their methods are composed into the consuming class, they can do a little more for you automatically. As long as you declare your imports before calling "use Moo::Role", those imports and the ones Moo::Role itself provides will not be composed into consuming classes, so there's usually no need to use namespace::clean. On namespace::autoclean: If you're coming to Moo from the Moose world, you may be accustomed to using namespace::autoclean in all your packages. This is not recommended for Moo packages, because namespace::autoclean will inflate your class to a full Moose class. It'll work, but you will lose the benefits of Moo. Instead you are recommended to just use namespace::clean. INCOMPATIBILITIES WITH MOOSE There is no built-in type system. "isa" is verified with a coderef; if you need complex types, just make a library of coderefs, or better yet, functions that return quoted subs. MooX::Types::MooseLike provides a similar API to MooseX::Types::Moose so that you can write has days_to_live => (is => 'ro', isa => Int); and have it work with both; it is hoped that providing only subrefs as an API will encourage the use of other type systems as well, since it's probably the weakest part of Moose design-wise. "initializer" is not supported in core since the author considers it to be a bad idea and Moose best practices recommend avoiding it. Meanwhile "trigger" or "coerce" are more likely to be able to fulfill your needs. There is no meta object. If you need this level of complexity you wanted Moose - Moo succeeds at being small because it explicitly does not provide a metaprotocol. However, if you load Moose, then Class::MOP::class_of($moo_class_or_role) will return an appropriate metaclass pre-populated by Moo. No support for "super", "override", "inner", or "augment" - the author considers augment to be a bad idea, and override can be translated: override foo => sub { ... super(); ... }; around foo => sub { my ($orig, $self) = (shift, shift); ... $self->$orig(@_); ... }; The "dump" method is not provided by default. The author suggests loading Devel::Dwarn into "main::" (via "perl -MDevel::Dwarn ..." for example) and using "$obj->$::Dwarn()" instead. "default" only supports coderefs and plain scalars, because passing a hash or array reference as a default is almost always incorrect since the value is then shared between all objects using that default. "lazy_build" is not supported; you are instead encouraged to use the "is => 'lazy'" option supported by Moo and MooseX::AttributeShortcuts. "auto_deref" is not supported since the author considers it a bad idea and it has been considered best practice to avoid it for some time. "documentation" will show up in a Moose metaclass created from your class but is otherwise ignored. Then again, Moose ignores it as well, so this is arguably not an incompatibility. Since "coerce" does not require "isa" to be defined but Moose does require it, the metaclass inflation for coerce alone is a trifle insane and if you attempt to subtype the result will almost certainly break. "BUILDARGS" is not triggered if your class does not have any attributes. Without attributes, "BUILDARGS" return value would be ignored, so we just skip calling the method instead. Handling of warnings: when you "use Moo" we enable FATAL warnings, and some several extra pragmas when used in development: indirect, multidimensional, and bareword::filehandles. See the strictures documentation for the details on this. A similar invocation for Moose would be: use Moose; use warnings FATAL => "all"; 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; The nearest Moose invocation would be: package MyClass; use Moose; use warnings FATAL => "all"; use MooseX::AttributeShortcuts; or, if you're inheriting from a non-Moose class, package MyClass; use Moose; use MooseX::NonMoose; use warnings FATAL => "all"; use MooseX::AttributeShortcuts; Finally, Moose requires you to call __PACKAGE__->meta->make_immutable; at the end of your class to get an inlined (i.e. not horribly slow) constructor. Moo does it automatically the first time ->new is called on your class. ("make_immutable" is a no-op in Moo to ease migration.) An extension MooX::late exists to ease translating Moose packages to Moo by providing a more Moose-like interface. SUPPORT Users' IRC: #moose on irc.perl.org Development and contribution IRC: #web-simple on irc.perl.org Bugtracker: Git repository: Git browser: AUTHOR mst - Matt S. Trout (cpan:MSTROUT) CONTRIBUTORS dg - David Leadbeater (cpan:DGL) frew - Arthur Axel "fREW" Schmidt (cpan:FREW) hobbs - Andrew Rodland (cpan:ARODLAND) jnap - John Napiorkowski (cpan:JJNAPIORK) ribasushi - Peter Rabbitson (cpan:RIBASUSHI) chip - Chip Salzenberg (cpan:CHIPS) ajgb - Alex J. G. Burzyński (cpan:AJGB) doy - Jesse Luehrs (cpan:DOY) perigrin - Chris Prather (cpan:PERIGRIN) Mithaldu - Christian Walde (cpan:MITHALDU) ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) tobyink - Toby Inkster (cpan:TOBYINK) haarg - Graham Knop (cpan:HAARG) mattp - Matt Phillips (cpan:MATTP) bluefeet - Aran Deltac (cpan:BLUEFEET) COPYRIGHT Copyright (c) 2010-2011 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 . Moo-1.004002/t/000755 000765 000024 00000000000 12260624267 013225 5ustar00gknopstaff000000 000000 Moo-1.004002/xt/000755 000765 000024 00000000000 12260624267 013415 5ustar00gknopstaff000000 000000 Moo-1.004002/xt/global-destruct-jenga.t000644 000765 000024 00000000252 12251110750 017741 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; my $out = `$^X xt/global-destruct-jenga-helper.pl 2>&1`; is $out, '', 'no errors from global destruct of jenga object'; done_testing; Moo-1.004002/xt/handle_moose.t000644 000765 000024 00000002570 12257055750 016244 0ustar00gknopstaff000000 000000 use strictures 1; use Test::Fatal; BEGIN { require "t/moo-accessors.t"; } require Moose; my $meta = Class::MOP::get_metaclass_by_name('Foo'); my $attr; ok($attr = $meta->get_attribute('one'), 'Meta-attribute exists'); is($attr->get_read_method, 'one', 'Method name'); is($attr->get_read_method_ref->body, Foo->can('one'), 'Right method'); is(Foo->new(one => 1, THREE => 3)->one, 1, 'Accessor still works'); is( Foo->meta->get_attribute('one')->get_read_method, 'one', 'Method name via ->meta' ); $meta = Moose::Meta::Class->initialize('Spoon'); $meta->superclasses('Moose::Object'); Moose::Util::apply_all_roles($meta, 'Bar'); my $spoon = Spoon->new(four => 4); is($spoon->four, 4, 'Role application ok'); { package MooRequiresFour; use Moo::Role; requires 'four'; package MooRequiresGunDog; use Moo::Role; requires 'gun_dog'; } is exception { Moose::Util::apply_all_roles($meta, 'MooRequiresFour'); }, undef, 'apply role with satisified requirement'; ok exception { Moose::Util::apply_all_roles($meta, 'MooRequiresGunDog'); }, 'apply role with unsatisified requirement'; { package WithNonMethods; use Scalar::Util qw(looks_like_number); use Moo; my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__); ::ok(!$meta->has_method('looks_like_number'), 'imported sub before use Moo not included in inflated metaclass'); } done_testing; Moo-1.004002/xt/implicit-moose-types.t000644 000765 000024 00000001162 12251013511 017656 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Moose::Util::TypeConstraints qw(find_type_constraint); { package TestRole; use Moo::Role; } { package TestClass; use Moo; with 'TestRole'; } my $o = TestClass->new; foreach my $name (qw(TestClass TestRole)) { ok !find_type_constraint($name), "No $name constraint created without Moose loaded"; } note "Loading Moose"; require Moose; foreach my $name (qw(TestClass TestRole)) { my $tc = find_type_constraint($name); isa_ok $tc, 'Moose::Meta::TypeConstraint', "$name constraint" and ok $tc->check($o), "TestClass object passes $name constraint"; } done_testing; Moo-1.004002/xt/jenga.t000644 000765 000024 00000001363 12217207473 014667 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package Tower1; use Moo; has 'attr1' => (is => 'ro', required => 1); package Tower2; use Moose; extends 'Tower1'; has 'attr2' => (is => 'ro', required => 1); __PACKAGE__->meta->make_immutable; package Tower3; use Moo; extends 'Tower2'; has 'attr3' => (is => 'ro', required => 1); package Tower4; use Moose; extends 'Tower3'; has 'attr4' => (is => 'ro', required => 1); __PACKAGE__->meta->make_immutable; } foreach my $num (1..4) { my $class = "Tower${num}"; my @attrs = map "attr$_", 1..$num; my %args = map +($_ => "${_}_value"), @attrs; my $obj = $class->new(%args); is($obj->{$_}, "${_}_value", "Attribute $_ ok for $class") for @attrs; } done_testing; Moo-1.004002/xt/lib/000755 000765 000024 00000000000 12260624267 014163 5ustar00gknopstaff000000 000000 Moo-1.004002/xt/moo-attr-handles-moose-role.t000644 000765 000024 00000000756 12257101143 021034 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package MooseRole; use Moose::Role; sub warble { "warble" } $INC{"MooseRole.pm"} = __FILE__; } { package MooseClass; use Moose; with 'MooseRole'; } { package MooClass; use Moo; has attr => ( is => 'ro', handles => 'MooseRole', ); } my $o = MooClass->new(attr => MooseClass->new); isa_ok( $o, 'MooClass' ); can_ok( $o, 'warble' ); is( $o->warble, "warble", 'Delegated method called correctly' ); done_testing; Moo-1.004002/xt/moo-consume-moose-role-coerce.t000644 000765 000024 00000001035 12217207473 021355 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; { package RoleOne; use Moose::Role; use Moose::Util::TypeConstraints; use namespace::autoclean; subtype 'Foo', as 'Int'; coerce 'Foo', from 'Str', via { 3 }; has foo => ( is => 'rw', isa => 'Foo', coerce => 1, clearer => '_clear_foo', ); } { package Class; use Moo; # Works if use Moose.. use namespace::clean -except => 'meta'; with 'RoleOne'; } my $i = Class->new( foo => 'bar' ); is $i->foo, 3; done_testing; Moo-1.004002/xt/moo-consume-moose-role-multiple.t000644 000765 000024 00000000707 12251110750 021742 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package RoleOne; use Moose::Role; has foo => ( is => 'rw' ); } { package RoleTwo; use Moose::Role; has bar => ( is => 'rw' ); } { package SomeClass; use Moo; with 'RoleOne', 'RoleTwo'; } my $i = SomeClass->new( foo => 'bar', bar => 'baz' ); is $i->foo, 'bar', "attribute from first role is correct"; is $i->bar, 'baz', "attribute from second role is correct"; done_testing; Moo-1.004002/xt/moo-consume-mouse-role-coerce.t000644 000765 000024 00000001031 12257101143 021346 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; { package RoleOne; use Mouse::Role; use Mouse::Util::TypeConstraints; use namespace::clean; subtype 'Foo', as 'Int'; coerce 'Foo', from 'Str', via { 3 }; has foo => ( is => 'rw', isa => 'Foo', coerce => 1, clearer => '_clear_foo', ); } { package Class; use Moo; # Works if use Moose.. use namespace::clean -except => 'meta'; with 'RoleOne'; } my $i = Class->new( foo => 'bar' ); is $i->foo, 3; done_testing; Moo-1.004002/xt/moo-does-moose-role.t000644 000765 000024 00000010550 12257101143 017371 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; BEGIN { package Ker; use Moo::Role; sub has_ker {} } BEGIN { package Splat; use Moose::Role; requires 'monkey'; sub punch { 1 } sub jab { 0 } around monkey => sub { 'OW' }; has trap => (is => 'ro', default => sub { -1 }); sub has_splat {} } BEGIN { package KerSplat; use Moo::Role; with qw/ Ker Splat /; } BEGIN { package Splat2; use Mouse::Role; requires 'monkey'; sub punch { 1 } sub jab { 0 } around monkey => sub { 'OW' }; has trap => (is => 'ro', default => sub { -1 }); sub has_splat {} } BEGIN { package KerSplat2; use Moo::Role; with qw/ Ker Splat2 /; } BEGIN { package Splattered; use Moo; sub monkey { 'WHAT' } with 'Splat'; sub jab { 3 } } BEGIN { package Splattered2; use Moo; sub monkey { 'WHAT' } with 'Splat2'; sub jab { 3 } } BEGIN { package Ker::Splattered; use Moo; sub monkey { 'WHAT' } with qw/ Ker Splat /; sub jab { 3 } } BEGIN { package Ker::Splattered2; use Moo; sub monkey { 'WHAT' } with qw/ Ker Splat2 /; sub jab { 3 } } BEGIN { package KerSplattered; use Moo; sub monkey { 'WHAT' } with qw/ KerSplat /; sub jab { 3 } } BEGIN { package KerSplattered2; use Moo; sub monkey { 'WHAT' } with qw/ KerSplat2 /; sub jab { 3 } } BEGIN { package Plunk; use Moo::Role; has pp => (is => 'rw', moosify => sub { my $spec = shift; $spec->{documentation} = 'moosify'; }); } BEGIN { package Plank; use Moo; use Sub::Quote; has vv => (is => 'rw', moosify => [quote_sub(q| $_[0]->{documentation} = 'moosify'; |), sub { $_[0]->{documentation} = $_[0]->{documentation}.' foo'; }]); } BEGIN { package Plunker; use Moose; with 'Plunk'; } BEGIN { package Planker; use Moose; extends 'Plank'; } BEGIN { package Plonk; use Moo; has kk => (is => 'rw', moosify => [sub { $_[0]->{documentation} = 'parent'; }]); } BEGIN { package Plonker; use Moo; extends 'Plonk'; has '+kk' => (moosify => sub { my $spec = shift; $spec->{documentation} .= 'child'; }); } BEGIN{ local $SIG{__WARN__} = sub { fail "warning: $_[0]" }; package SplatteredMoose; use Moose; extends 'Splattered'; } foreach my $s ( Splattered->new, Splattered2->new, Ker::Splattered->new, Ker::Splattered2->new, KerSplattered->new, KerSplattered2->new, SplatteredMoose->new ) { can_ok($s, 'punch') and is($s->punch, 1, 'punch'); can_ok($s, 'jab') and is($s->jab, 3, 'jab'); can_ok($s, 'monkey') and is($s->monkey, 'OW', 'monkey'); can_ok($s, 'trap') and is($s->trap, -1, 'trap'); } foreach my $c (qw/ Ker::Splattered Ker::Splattered2 KerSplattered KerSplattered2 /) { can_ok($c, 'has_ker'); can_ok($c, 'has_splat'); } is(Plunker->meta->find_attribute_by_name('pp')->documentation, 'moosify', 'moosify modifies attr specs'); is(Planker->meta->find_attribute_by_name('vv')->documentation, 'moosify foo', 'moosify modifies attr specs as array'); is( Plonker->meta->find_attribute_by_name('kk')->documentation, 'parentchild', 'moosify applies for overridden attributes with roles'); is ref Splattered2->meta, 'Moo::HandleMoose::FakeMetaClass', 'Mouse::Role meta method not copied'; { package MooseAttrTrait; use Moose::Role; has 'extra_attr' => (is => 'ro'); has 'extra_attr_noinit' => (is => 'ro', init_arg => undef); } { local $SIG{__WARN__} = sub { fail "warning: $_[0]" }; package UsingMooseTrait; use Moo; has one => ( is => 'ro', traits => ['MooseAttrTrait'], extra_attr => 'one', extra_attr_noinit => 'two', ); } ok( UsingMooseTrait->meta ->find_attribute_by_name('one')->can('extra_attr'), 'trait was properly applied'); is( UsingMooseTrait->meta->find_attribute_by_name('one') ->extra_attr, 'one', 'trait attributes maintain values'); { package NeedTrap; use Moo::Role; requires 'trap'; } is exception { package Splattrap; use Moo; sub monkey {} with qw(Splat NeedTrap); }, undef, 'requires satisfied by Moose attribute composed at the same time'; { package HasMonkey; use Moo; sub monkey {} } is exception { Moo::Role->create_class_with_roles('HasMonkey', 'Splat', 'NeedTrap'); }, undef, ' ... and when created by create_class_with_roles'; done_testing; Moo-1.004002/xt/moo-object-meta-can.t000644 000765 000024 00000002571 12251110750 017313 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use Moo::Object; # See RT#84615 ok( Moo::Object->can('meta'), 'Moo::Object can meta'); is( exception { Moo::Object->meta->can('can') } , undef, "Moo::Object->meta->can doesn't explode" ); { package Example; use base 'Moo::Object'; } ok( Example->can('meta'), 'Example can meta'); is( exception { Example->meta->can('can') } , undef, "Example->meta->can doesn't explode" ); # Haarg++ noting that previously, this *also* would have died due to its absence from %Moo::Makers; { package Example_2; use Moo; has 'attr' => ( is => ro =>, ); $INC{'Example_2.pm'} = 1; } { package Example_3; use base "Example_2"; } ok( Example_2->can('meta'), 'Example_2 can meta') and do { return unless ok( Example_2->meta->can('get_all_attributes'), 'Example_2 meta can get_all_attributes' ); my (@attributes) = Example_2->meta->get_all_attributes; is( scalar @attributes, 1, 'Has one attribute' ); }; ok( Example_3->can('meta'), 'Example_3 can meta') and do { return unless is( exception { Example_3->meta->can('can') } , undef, "Example_3->meta->can doesn't explode" ); return unless ok( Example_3->meta->can('get_all_attributes'), 'Example_3 meta can get_all_attributes' ); my (@attributes) = Example_3->meta->get_all_attributes; is( scalar @attributes, 1, 'Has one attribute' ); }; done_testing; Moo-1.004002/xt/moo-role-types.t000644 000765 000024 00000003171 12216242004 016461 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; { package TestClientClass; use Moo; use namespace::clean -except => 'meta'; sub consume {} } { package TestBadClientClass; use Moo; use namespace::clean -except => 'meta'; sub not_consume {} } { package TestRole; use Moo::Role; use Sub::Quote; use namespace::clean -except => 'meta'; has output_to => ( isa => quote_sub(q{ use Scalar::Util (); die $_[0] . "Does not have a ->consume method" unless Scalar::Util::blessed($_[0]) && $_[0]->can('consume'); }), is => 'ro', required => 1, coerce => quote_sub(q{ use Scalar::Util (); if (Scalar::Util::blessed($_[0]) && $_[0]->can('consume')) { $_[0]; } else { my %stuff = %{$_[0]}; my $class = delete($stuff{class}); $class->new(%stuff); } }), ); } { package TestMooClass; use Moo; with 'TestRole'; } { package TestMooseClass; use Moose; with 'TestRole'; } foreach my $name (qw/ TestMooClass TestMooseClass /) { my $i = $name->new(output_to => TestClientClass->new()); ok $i->output_to->can('consume'); $i = $name->new(output_to => { class => 'TestClientClass' }); ok $i->output_to->can('consume'); }; foreach my $name (qw/ TestMooClass TestMooseClass /) { ok !exception { TestBadClientClass->new }; ok exception { $name->new(output_to => TestBadClientClass->new()) }; ok exception { $name->new(output_to => { class => 'TestBadClientClass' }) }; } done_testing; Moo-1.004002/xt/moo-roles-into-moose-class-attr-override-with-autoclean.t000644 000765 000024 00000000404 12216242004 026377 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use FindBin qw/ $Bin /; use lib "$Bin/lib"; { package Bax; use Moose; with qw/ ExampleMooRoleWithAttribute /; has '+output_to' => ( required => 1, ); } ok 1; done_testing; Moo-1.004002/xt/moo-roles-into-moose-class.t000644 000765 000024 00000002414 12251110750 020674 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moo::Role; # if we autoclean here there's nothing left and then load_class tries # to require Foo during Moose application and everything breaks. } { package Bar; use Moo::Role; use namespace::autoclean; has attr => ( is => 'ro' ); sub thing {} } { package Baz; use Moose; no Moose; ::ok(!__PACKAGE__->can('has'), 'No has function after no Moose;'); Moose::with('Baz', 'Bar'); } ::is(Baz->can('thing'), Bar->can('thing'), 'Role copies method correctly'); ::ok(Baz->can('attr'), 'Attr accessor correct'); ::ok(!Bar->can('has'), 'Moo::Role sugar removed by autoclean'); ::ok(!Bar->can('with'), 'Role::Tiny sugar removed by autoclean'); ::ok(!Baz->can('has'), 'Sugar not copied'); { package Bax; use Moose; with qw/ Foo Bar /; } { package Baw; use Moo::Role; has attr => ( is => 'ro', traits => ['Array'], default => sub { [] }, handles => { push_attr => 'push', }, ); } { package Buh; use Moose; with 'Baw'; } is exception { Buh->new->push_attr(1); }, undef, 'traits in role attributes are inflated properly'; done_testing; Moo-1.004002/xt/moo-sification.t000644 000765 000024 00000000417 12251110750 016507 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; BEGIN { package Foo; use Moo; has one => (is => 'ro'); } no Moo::sification; use Moose; use Class::MOP; is Class::MOP::get_metaclass_by_name('Foo'), undef, 'no metaclass for Moo class after no Moo::sification'; done_testing; Moo-1.004002/xt/moose-accessor-isa.t000644 000765 000024 00000002344 12251110750 017264 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; { package FrewWithIsa; use Moo::Role; use Sub::Quote; has frooh => ( is => 'rw', isa => sub { die 'not int' unless $_[0] =~ /^\d$/ }, ); has frew => ( is => 'rw', isa => quote_sub(q{ die 'not int' unless $_[0] =~ /^\d$/ }), ); package Bar; use Moose; with 'FrewWithIsa'; package OffByOne; use Moo::Role; has off_by_one => (is => 'rw', coerce => sub { $_[0] + 1 }); package Baz; use Moo; with 'OffByOne'; package Quux; use Moose; with 'OffByOne'; __PACKAGE__->meta->make_immutable; } is(exception { Bar->new(frooh => 1, frew => 1); }, undef, 'creation of valid Bar'); ok exception { Bar->new(frooh => 'silly', frew => 1); }, 'creation of invalid Bar validated by coderef'; ok exception { Bar->new(frooh => 1, frew => 'goose'); }, 'creation of invalid Bar validated by quoted sub'; sub test_off_by_one { my ($class, $type) = @_; my $obo = $class->new(off_by_one => 1); is($obo->off_by_one, 2, "Off by one (new) ($type)"); $obo->off_by_one(41); is($obo->off_by_one, 42, "Off by one (set) ($type)"); } test_off_by_one('Baz', 'Moo'); test_off_by_one('Quux', 'Moose'); done_testing; Moo-1.004002/xt/moose-autoclean-lazy-attr-builders.t000644 000765 000024 00000001101 12216242004 022404 0ustar00gknopstaff000000 000000 use strict; use warnings; # when using an Moose object and namespace::autoclean # lazy attributes that get a value on initialize still # have their builders run { package MyMooseObject; use Moose; } { package BadObject; use Moo; # use MyMooseObject <- this is inferred here use namespace::autoclean; has attr => ( is => 'lazy' ); sub _build_attr {2} } use Test::More; # use BadObject <- this is inferred here is( BadObject->new( attr => 1 )->attr, 1, q{namespace::autoclean doesn't run builders with default}, ); done_testing; Moo-1.004002/xt/moose-consume-moo-role-after-consumed-by-moo.t000644 000765 000024 00000000515 12251013511 024215 0ustar00gknopstaff000000 000000 use strictures; use Test::More; use lib 'xt/lib'; BEGIN { $::ExampleMooRole_LOADED = 0 } BEGIN { package ExampleMooConsumer; use Moo; with "ExampleMooRole"; } BEGIN { package ExampleMooseConsumer; use Moose; with "ExampleMooRole"; } is $::ExampleMooRole_LOADED, 1, "role loaded only once"; done_testing; Moo-1.004002/xt/moose-consume-moo-role-no-moo-loaded.t000644 000765 000024 00000000271 12216242004 022534 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; { package ExampleRole; use Moo::Role; } { package ExampleClass; use Moose; with 'ExampleRole'; } ok 1; done_testing; Moo-1.004002/xt/moose-does-moo-role.t000644 000765 000024 00000002377 12251110750 017377 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; { package MooParentRole; use Moo::Role; sub parent_role_method { 1 }; package MooRole; use Moo::Role; with 'MooParentRole'; sub role_method { 1 }; package MooRoledMooClass; use Moo; with 'MooRole'; has 'some_attr' => (is => 'ro'); package MooRoledMooseClass; use Moose; with 'MooRole'; has 'some_attr' => (is => 'ro'); package MooseParent; use Moose; has e => ( is => 'ro', required => 1, does => 'MooRole', ); package MooParent; use Moo; has e => ( is => 'ro', required => 1, does => 'MooRole', ); } for my $parent (qw(MooseParent MooParent)) { for my $child (qw(MooRoledMooClass MooRoledMooseClass)) { is(exception { my $o = $parent->new( e => $child->new(), ); ok( $o->e->does("MooParentRole"), "$child does parent MooRole" ); can_ok( $o->e, "role_method" ); can_ok( $o->e, "parent_role_method" ); ok($o->e->meta->has_method('role_method'), 'Moose knows about role_method'); ok($o->e->meta->has_method('parent_role_method'), 'Moose knows about parent_role_method'); }, undef); } } done_testing; Moo-1.004002/xt/moose-lazy.t000644 000765 000024 00000003106 12251110750 015664 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package LazyFrew; our $default_ran = 0; our $quoted_default_ran = 0; our $builder_ran = 0; use Moo::Role; use Sub::Quote; has frooh => ( is => 'rw', default => sub { $default_ran = 1; 'test frooh' }, lazy => 1, ); has frew => ( is => 'rw', default => quote_sub(q{ $$quoted_default_ran = 1; 'test frew' }, { '$quoted_default_ran' => \\$quoted_default_ran }), lazy => 1, ); has frioux => ( is => 'rw', builder => 'build_frioux', lazy => 1, ); sub build_frioux { $builder_ran = 1; 'test frioux' } package Bar; use Moose; with 'LazyFrew'; } my $x = Bar->new; ok(!$LazyFrew::default_ran, 'default has not run yet'); ok(!$LazyFrew::quoted_default_ran, 'quoted default has not run yet'); ok(!$LazyFrew::builder_ran, 'builder has not run yet'); is($x->frooh, 'test frooh', 'frooh defaulted correctly'); ok($LazyFrew::default_ran, 'default ran'); ok(!$LazyFrew::quoted_default_ran, 'quoted default has not run yet'); ok(!$LazyFrew::builder_ran, 'builder has not run yet'); is($x->frew, 'test frew', 'frew defaulted correctly'); ok($LazyFrew::default_ran, 'default ran'); ok($LazyFrew::quoted_default_ran, 'quoted default ran'); ok(!$LazyFrew::builder_ran, 'builder has not run yet'); is($x->frioux, 'test frioux', 'frioux built correctly'); ok($LazyFrew::default_ran, 'default ran'); ok($LazyFrew::quoted_default_ran, 'quoted default ran'); ok($LazyFrew::builder_ran, 'builder ran'); done_testing; Moo-1.004002/xt/moose-method-modifiers.t000644 000765 000024 00000002250 12251110750 020143 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package ModifyFoo; use Moo::Role; our $before_ran = 0; our $around_ran = 0; our $after_ran = 0; before foo => sub { $before_ran = 1 }; after foo => sub { $after_ran = 1 }; around foo => sub { my ($orig, $self, @rest) = @_; $self->$orig(@rest); $around_ran = 1; }; package Bar; use Moose; with 'ModifyFoo'; sub foo { } } my $bar = Bar->new; ok(!$ModifyFoo::before_ran, 'before has not run yet'); ok(!$ModifyFoo::after_ran, 'after has not run yet'); ok(!$ModifyFoo::around_ran, 'around has not run yet'); $bar->foo; ok($ModifyFoo::before_ran, 'before ran'); ok($ModifyFoo::after_ran, 'after ran'); ok($ModifyFoo::around_ran, 'around ran'); { package ModifyMultiple; use Moo::Role; our $before = 0; before 'foo', 'bar' => sub { $before++; }; package Baz; use Moose; with 'ModifyMultiple'; sub foo {} sub bar {} } my $baz = Baz->new; my $pre = $ModifyMultiple::before; $baz->foo; is $ModifyMultiple::before, $pre+1, "before applies to first of multiple subs"; $baz->bar; is $ModifyMultiple::before, $pre+2, "before applies to second of multiple subs"; done_testing; Moo-1.004002/xt/moose-override-attribute-from-moo-role.t000644 000765 000024 00000001043 12216242004 023212 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; { package MyRole; use Moo::Role; has foo => ( is => 'ro', required => 1, ); } { package MyClass; use Moose; with 'MyRole'; has '+foo' => ( isa => 'Str', ); } is( exception { MyClass->new(foo => 'bar') }, undef, 'construct' ); ok( exception { MyClass->new(foo => []) }, 'no construct, constraint works' ); ok( exception { MyClass->new() }, 'no construct - require still works' ); done_testing; Moo-1.004002/xt/moose-override-attribute-with-plus-syntax.t000644 000765 000024 00000002013 12251110750 023777 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; { package MooParent; use Moo; has foo => ( is => 'ro', default => sub { 'MooParent' }, ); } { package MooseChild; use Moose; extends 'MooParent'; has '+foo' => ( default => 'MooseChild', ); } { package MooseChild2; use Moose; extends 'MooParent'; has '+foo' => ( default => 'MooseChild2', ); __PACKAGE__->meta->make_immutable } { package MooChild; use Moo; extends 'MooParent'; has '+foo' => ( default => sub { 'MooChild' }, ); } is( MooseChild->new->foo, 'MooseChild', 'default value in Moose child' ); is( MooseChild2->new->foo, 'MooseChild2', 'default value in Moose child' ); is(exception { local $SIG{__WARN__} = sub { die $_[0] }; ok(MooChild->meta->has_attribute('foo'), 'inflated metaclass has overridden attribute'); }, undef, 'metaclass inflation of plus override works without warnings'); done_testing; Moo-1.004002/xt/more-jenga.t000644 000765 000024 00000000530 12216242004 015606 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use FindBin qw/ $Bin /; use lib "$Bin/lib"; { package ExampleRole; use Moo::Role; requires 'foo'; with qw/ ExampleMooseRoleOne ExampleMooseRoleTwo /; } { package ExampleClass; use Moose; with 'ExampleRole'; sub foo {} } ok 1; done_testing; Moo-1.004002/xt/strictures.t000644 000765 000024 00000004076 12257060677 016025 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; # make sure these are really loaded no indirect 'fatal'; no multidimensional; no bareword::filehandles; plan skip_all => "test must be run from git checkout" unless -e '.git'; our %test_hash; # inc hook to separate context my $header = q{ #line 1 "%1$s/_t/%2$s.pm" package %1$s::_t::%2$s; use Moo; }; my %checks = ( multi => 'my $f = $::test_hash{1,2};', indirect => 'my $f = new Test::Builder;', bareword => 'open IO, ">", \(my $f);', ); unshift @INC, sub { if ($_[1] =~ m{(.*)/_t/(.*)\.pm}) { my $content = sprintf($header, $1, $2) . $checks{$2} . "\n1;\n"; open my $fh, '<', \$content; return $fh; } return; }; my $multi_re = qr/Use of multidimensional array emulation/; like exception { require t::_t::multi; }, $multi_re, 'files in t get multidimensional strictures'; like exception { require lib::_t::multi; }, $multi_re, 'files in lib get multidimensional strictures'; like exception { require xt::_t::multi; }, $multi_re, 'files in xt get multidimensional strictures'; is exception { require other::_t::multi; }, undef, 'files elsewhere don\'t get multidimensional strictures'; my $indirect_re = qr/Indirect call of method/; like exception { require t::_t::indirect; }, $indirect_re, 'files in t get indirect strictures'; like exception { require lib::_t::indirect; }, $indirect_re, 'files in lib get indirect strictures'; like exception { require xt::_t::indirect; }, $indirect_re, 'files in xt get indirect strictures'; is exception { require other::_t::indirect; }, undef, 'files elsewhere don\'t get indirect strictures'; my $bareword_re = qr/Use of bareword filehandle/; like exception { require t::_t::bareword; }, $bareword_re, 'files in t get bareword strictures'; like exception { require lib::_t::bareword; }, $bareword_re, 'files in lib get bareword strictures'; like exception { require xt::_t::bareword; }, $bareword_re, 'files in xt get bareword strictures'; is exception { require other::_t::bareword; }, undef, 'files elsewhere don\'t get bareword strictures'; done_testing; Moo-1.004002/xt/super-jenga.t000644 000765 000024 00000001152 12217207473 016017 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package Tower1; use Mouse; has 'attr1' => (is => 'ro', required => 1); package Tower2; use Moo; extends 'Tower1'; has 'attr2' => (is => 'ro', required => 1); package Tower3; use Moose; extends 'Tower2'; has 'attr3' => (is => 'ro', required => 1); __PACKAGE__->meta->make_immutable; } foreach my $num (1..3) { my $class = "Tower${num}"; my @attrs = map "attr$_", 1..$num; my %args = map +($_ => "${_}_value"), @attrs; my $obj = $class->new(%args); is($obj->{$_}, "${_}_value", "Attribute $_ ok for $class") for @attrs; } done_testing; Moo-1.004002/xt/test-my-dependents.t000644 000765 000024 00000014534 12251173653 017340 0ustar00gknopstaff000000 000000 use Test::More; BEGIN { plan skip_all => <<'END_HELP' unless $ENV{MOO_TEST_MD} || @ARGV; This test will not run unless you set MOO_TEST_MD to a true value. Valid values are: all Test every dist which depends on Moose except those that we know cannot be tested. This is a lot of distros (hundreds). Dist::1,Dist::2,... Test the individual dists listed. MooX Test all Moo extension distros. 1 Run the default tests. We pick 200 random dists and test them. END_HELP } use Test::DependentModules qw( test_module ); use MetaCPAN::API; use List::Util (); # avoid any modules that depend on these my @bad_prereqs = qw(Gtk2 Padre Wx); my $mcpan = MetaCPAN::API->new; my $res = $mcpan->post( '/search/reverse_dependencies/Moo' => { query => { filtered => { query => { "match_all" => {} }, filter => { and => [ { term => { 'release.status' => 'latest' } }, { term => { 'release.authorized' => \1 } }, { not => { filter => { or => [ map { { term => { 'dependency.module' => $_ } } } @bad_prereqs, ], } } } ], }, }, }, size => 5000, fields => ['distribution', 'provides', 'metadata.provides'], }, ); my %bad_dist; my $sec_reason; my %skip; my %todo; my $hash; for my $line () { chomp $line; next unless $line =~ /\S/; if ( $line =~ /^#\s*(\w+)(?::\s*(.*?)\s*)?$/ ) { die "Invalid action in DATA section ($1)" unless $1 eq 'SKIP' || $1 eq 'TODO'; $hash = $1 eq 'SKIP' ? \%skip : \%todo; $sec_reason = $2; } my ( $dist, $reason ) = $line =~ /^(\S*)\s*(?:#\s*(.*?)\s*)?$/; next unless defined $dist && length $dist; $hash->{$dist} = $reason ? "$sec_reason: $reason" : $reason; } my %todo_module; my @modules; for my $hit (@{ $res->{hits}{hits} }) { my $dist = $hit->{fields}{distribution}; next if exists $skip{$dist}; next if $dist =~ /^(?:Task|Bundle|Acme)-/; my $module = (sort { length $a <=> length $b || $a cmp $b } do { if (my $provides = $hit->{fields}{provides}) { ref $provides ? @$provides : ($provides); } elsif (my $provides = $hit->{fields}{'metadata.provides'}) { keys %$provides; } else { (my $module = $dist) =~ s/-/::/g; ($module); } })[0]; $todo_module{$module} = $todo{$dist} if exists $todo{$dist}; push @modules, $module; $module; } @modules = sort @modules; my @args = grep { $_ ne '--show' } @ARGV; my $show = @args != @ARGV; my $pick = $ENV{MOO_TEST_MD} || shift @args || 'all'; if ( $pick eq 'MooX' ) { @modules = grep /^MooX(?:$|::)/, @modules; } elsif ( $pick =~ /^\d+$/ ) { my $count = $pick == 1 ? 200 : $pick; diag(<<"EOF"); Picking $count random dependents to test. Set MOO_TEST_MD=all to test all dependents or MOO_TEST_MD=MooX to test extension modules only. EOF @modules = (List::Util::shuffle(@modules))[0 .. $count-1]; } elsif ( $pick ne 'all' ) { my @chosen = split /,/, $ENV{MOO_TEST_MD}; my %modules = map { $_ => 1 } @modules; if (my @unknown = grep { !$modules{$_} } @chosen) { die "Unknown modules: @unknown"; } @modules = @chosen; } if ($show) { print "Dependents:\n"; print " $_\n" for @modules; exit; } plan tests => scalar @modules; for my $module (@modules) { local $TODO = $todo_module{$module} || '???' if exists $todo_module{$module}; test_module($module); } __DATA__ # TODO: broken App-Presto # 0.009 Dancer2-Session-Sereal # 0.001 Mail-GcalReminder # 0.1 DBIx-Class-IndexSearch-Dezi # 0.05 Tak # 0.001003 HTML-Zoom-Parser-HH5P # 0.002 # TODO: broken prereqs Dancer-Plugin-FontSubset # 0.1.2 - Font::TTF::Scripts::Name # TODO: broken by perl 5.18 App-DBCritic # 0.020 - smartmatch (GH #9) App-OS-Detect-MachineCores # 0.038 - smartmatch (rt#88855) Authen-HTTP-Signature # 0.02 - smartmatch (rt#88854) DBICx-Backend-Move # 1.000010 - smartmatch (rt#88853) Ruby-VersionManager # 0.004003 - smartmatch (rt#88852) Text-Keywords # 0.900 - smartmatch (rt#84339) Log-Message-Structured-Stringify-AsSereal # 0.10 - hash order (GH #1) WebService-HabitRPG # 0.21 - smartmatch (rt#88399) App-Rssfilter # 0.03 - smartmatch (GH #2) Net-Icecast2 # 0.005 - hash order via PHP::HTTPBuildQuery (rt#81570) POE-Component-ProcTerminator # 0.03 - hash order via Log::Fu (rt#88851) # TODO: broken by Regexp::Grammars (perl 5.18) Data-Sah # 0.15 Language-Expr # 0.19 Org-To-HTML # 0.07 - via Language::Expr Perinci-Access-Simple-Server # 0.12 Perinci-CmdLine # 0.85 - via Data::Sah Perinci-To-Text # 0.22 - via Data::Sah Perinci-Sub-To-Text # 0.24 - via Data::Sah Finance-Bank-ID-BCA # 0.26 - via Perinci::CmdLine Software-Release-Watch # 0.01 - via Data::Sah, Perinci::CmdLine Software-Release-Watch-SW-wordpress # 0.01 - via Software::Release::Watch # SKIP: invalid prereqs Catmandu-Z3950 # 0.03 - ZOOM missing Dancer2-Session-JSON # 0.001 - Dancer2 bad version requirement # SKIP: misc GeoIP2 # 0.040000 - prereq Math::Int128 (requires gcc 4.4) Graphics-Potrace # 0.72 - external dependency GraphViz2 # 2.19 - external dependency Linux-AtaSmart # OS specific MaxMind-DB-Reader # 0.040003 - prereq Math::Int128 (requires gcc 4.4) MaxMind-DB-Common # 0.031002 - prereq Math::Int128 (requires gcc 4.4) Net-Works # 0.12 - prereq Math::Int128 (requires gcc 4.4) PortageXS # 0.3.1 - external dependency and broken prereq (Shell::EnvImporter) XML-GrammarBase # v0.2.2 - prereq XML::LibXSLT (hard to install) Forecast-IO # 0.21 - interactive tests Net-OpenVPN-Launcher # 0.1 - external dependency (and broken test) App-PerlWatcher-Level # 0.13 - depends on Linux::Inotify2 Graph-Easy-Marpa # 2.00 - GraphVis2 Net-OAuth-LP # 0.016 - relies on external service Message-Passing-ZeroMQ # 0.007 - external dependency Net-Docker # 0.002003 - external dependency # TODO: broken by Moo change Math-Rational-Approx # RT#84035 App-Services # RT#85255 Hg-Lib # pending release Moo-1.004002/xt/type-inflate-coercion.t000644 000765 000024 00000002646 12251110750 017775 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; sub ArrayRef { my $type = sub { die unless ref $_[0] && ref $_[0] eq 'ARRAY'; }; $Moo::HandleMoose::TYPE_MAP{$type} = sub { require Moose::Util::TypeConstraints; Moose::Util::TypeConstraints::find_type_constraint("ArrayRef"); }; return ($type, @_); } { package ClassWithTypes; $INC{'ClassWithTypes.pm'} = __FILE__; use Moo; has split_comma => (is => 'ro', isa => ::ArrayRef, coerce => sub { [ split /,/, $_[0] ] } ); has split_space => (is => 'ro', isa => ::ArrayRef, coerce => sub { [ split / /, $_[0] ] } ); has bad_coerce => (is => 'ro', isa => ::ArrayRef, coerce => sub { $_[0] } ); } my $o = ClassWithTypes->new(split_comma => 'a,b c,d', split_space => 'a,b c,d'); is_deeply $o->split_comma, ['a','b c','d'], 'coerce with prebuilt type works'; is_deeply $o->split_space, ['a,b','c,d'], ' ... and with different coercion on same type'; { package MooseSubclassWithTypes; use Moose; extends 'ClassWithTypes'; } my $o2 = MooseSubclassWithTypes->new(split_comma => 'a,b c,d', split_space => 'a,b c,d'); is_deeply $o2->split_comma, ['a','b c','d'], 'moose subclass has correct coercion'; is_deeply $o2->split_space, ['a,b','c,d'], ' ... and with different coercion on same type'; like exception { MooseSubclassWithTypes->new(bad_coerce => 1) }, qr/Validation failed for 'ArrayRef' with value/, 'inflated type has correct name'; done_testing; Moo-1.004002/xt/type-inflate-threads.t000644 000765 000024 00000002624 12257102637 017635 0ustar00gknopstaff000000 000000 use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } } use threads; use strictures 1; use Test::More; use Type::Tiny; my $str = sub { die unless defined $_[0] && !ref $_[0]; }; no warnings 'once'; $Moo::HandleMoose::TYPE_MAP{$str} = sub { require Moose::Util::TypeConstraints; Moose::Util::TypeConstraints::find_type_constraint("Str"); }; my $int = Type::Tiny->new( name => "Integer", constraint => sub { /^(?:-?[1-9][0-9]*|0)$|/ }, message => sub { "$_ isn't an integer" }, ); require Moo; is(threads->create(sub { my $type = $str; eval q{ package TypeOMatic; use Moo; has str_type => ( is => 'ro', isa => $type, ); 1; } or die $@; require Moose; my $meta = Class::MOP::class_of('TypeOMatic'); my $str_name = $meta->get_attribute("str_type")->type_constraint->name; $str_name; })->join, 'Str', 'Type created outside thread properly inflated'); is(threads->create(sub { my $type = $int; eval q{ package TypeOMatic; use Moo; has int_type => ( is => 'ro', isa => $type, ); 1; } or die $@; require Moose; my $meta = Class::MOP::class_of('TypeOMatic'); my $int_class = ref $meta->get_attribute("int_type")->type_constraint; $int_class; })->join, 'Type::Tiny', 'Type::Tiny created outside thread inflates to self'); done_testing; Moo-1.004002/xt/type-inflate-type-tiny.t000644 000765 000024 00000001300 12260405032 020120 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package TypeOMatic; use Moo::Role; use Sub::Quote; use Moo::HandleMoose (); use Types::Standard qw(Str); has consumed_type => ( is => 'ro', isa => Str, ); package TypeOMatic::Consumer; # do this as late as possible to simulate "real" behaviour use Moo::HandleMoose; use Moose; use Types::Standard qw(Str); with 'TypeOMatic'; has direct_type => ( is => 'ro', isa => Str, ); } my $meta = Class::MOP::class_of('TypeOMatic::Consumer'); for my $attr (qw(consumed_type direct_type)) { my $type = $meta->get_attribute($attr)->type_constraint; isa_ok($type, 'Type::Tiny'); is($type->name, 'Str'); } done_testing; Moo-1.004002/xt/type-inflate.t000644 000765 000024 00000003511 12251110750 016166 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package TypeOMatic; use Moo::Role; use Sub::Quote; use Moo::HandleMoose (); sub Str { my $type = sub { die unless defined $_[0] && !ref $_[0]; }; $Moo::HandleMoose::TYPE_MAP{$type} = sub { require Moose::Util::TypeConstraints; Moose::Util::TypeConstraints::find_type_constraint("Str"); }; return ($type, @_); } sub PositiveInt { my $type = sub { die unless defined $_[0] && !ref $_[0] && $_[0] =~ /^-?\d+/; }; $Moo::HandleMoose::TYPE_MAP{$type} = sub { require Moose::Util::TypeConstraints; require MooseX::Types::Common::Numeric; Moose::Util::TypeConstraints::find_type_constraint( "MooseX::Types::Common::Numeric::PositiveInt"); }; return ($type, @_); } has named_type => ( is => 'ro', isa => Str, ); has named_external_type => ( is => 'ro', isa => PositiveInt, ); package TypeOMatic::Consumer; # do this as late as possible to simulate "real" behaviour use Moo::HandleMoose; use Moose; with 'TypeOMatic'; } my $meta = Class::MOP::class_of('TypeOMatic::Consumer'); my ($str, $positive_int) = map $meta->get_attribute($_)->type_constraint->name, qw(named_type named_external_type); is($str, 'Str', 'Built-in Moose type ok'); is( $positive_int, 'MooseX::Types::Common::Numeric::PositiveInt', 'External (MooseX::Types type) ok' ); local $@; eval q { package Fooble; use Moo; my $isa = sub { 1 }; $Moo::HandleMoose::TYPE_MAP{$isa} = sub { $isa }; has barble => (is => "ro", isa => $isa); __PACKAGE__->meta->get_attribute("barble"); }; like( $@, qr/^error inflating attribute 'barble' for package 'Fooble': \$TYPE_MAP\{CODE\(\w+?\)\} did not return a valid type constraint/, 'error message for incorrect type constraint inflation', ); done_testing; Moo-1.004002/xt/withautoclean.t000644 000765 000024 00000000206 12216242004 016431 0ustar00gknopstaff000000 000000 use strict; use warnings; use FindBin qw/ $Bin /; use lib "$Bin/lib"; use Test::More; use_ok 'withautoclean::Class'; done_testing; Moo-1.004002/xt/lib/ExampleMooRole.pm000644 000765 000024 00000000127 12251013511 017371 0ustar00gknopstaff000000 000000 package ExampleMooRole; use Moo::Role; $::ExampleMooRole_LOADED++; no Moo::Role; 1; Moo-1.004002/xt/lib/ExampleMooRoleWithAttribute.pm000644 000765 000024 00000000521 12216242004 022111 0ustar00gknopstaff000000 000000 package ExampleMooRoleWithAttribute;; use Moo::Role; # Note that autoclean here is the key bit! # It causes the metaclass to be loaded and used before the 'has' fires # so Moo needs to blow it away again at that point so the attribute gets # added use namespace::autoclean; has output_to => ( is => 'ro', required => 1, ); 1; Moo-1.004002/xt/lib/ExampleMooseRoleOne.pm000644 000765 000024 00000000063 12216242004 020364 0ustar00gknopstaff000000 000000 package ExampleMooseRoleOne; use Moose::Role; 1; Moo-1.004002/xt/lib/ExampleMooseRoleTwo.pm000644 000765 000024 00000000063 12216242004 020414 0ustar00gknopstaff000000 000000 package ExampleMooseRoleTwo; use Moose::Role; 1; Moo-1.004002/xt/lib/withautoclean/000755 000765 000024 00000000000 12260624267 017032 5ustar00gknopstaff000000 000000 Moo-1.004002/xt/lib/withautoclean/Class.pm000644 000765 000024 00000000146 12216242004 020420 0ustar00gknopstaff000000 000000 package withautoclean::Class; use Moo; with 'withautoclean::R1'; before _clear_ctx => sub { }; 1; Moo-1.004002/xt/lib/withautoclean/R1.pm000644 000765 000024 00000000554 12216242004 017640 0ustar00gknopstaff000000 000000 package withautoclean::R1; use Moo::Role; # Doing this (or loading a class which is built with Moose) # and then loading autoclean - everything breaks... use Moose (); use namespace::autoclean; # Wouldn't happen normally, but is likely to as you part-port something. has _ctx => ( is => 'ro', default => sub { }, clearer => '_clear_ctx', ); 1; Moo-1.004002/t/accessor-coerce.t000644 000765 000024 00000005351 12257055750 016457 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use lib "t/lib"; use ComplexWriter; 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'; ComplexWriter->test_with("coerce"); done_testing; Moo-1.004002/t/accessor-default.t000644 000765 000024 00000003702 12251110750 016623 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; 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 { {} } } 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'); done_testing; Moo-1.004002/t/accessor-generator-extension.t000644 000765 000024 00000003777 12216242004 021212 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; 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'); done_testing; Moo-1.004002/t/accessor-handles.t000644 000765 000024 00000004001 12251110750 016606 0ustar00gknopstaff000000 000000 use strictures 1; 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]} } { 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 } ); } 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 '; 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'; ok(exception { package Fuzz; use Moo; has foo => ( is => 'ro', handles => $bar ); }, 'invalid handles throws exception'); done_testing; Moo-1.004002/t/accessor-isa.t000644 000765 000024 00000006771 12257055750 016002 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use lib "t/lib"; use ComplexWriter; 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) }; is($called, 1, '__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'; ComplexWriter->test_with("isa"); done_testing; Moo-1.004002/t/accessor-mixed.t000644 000765 000024 00000001674 12216242004 016312 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; 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' ); done_testing; Moo-1.004002/t/accessor-pred-clear.t000644 000765 000024 00000001377 12216242004 017222 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/accessor-reader-writer.t000644 000765 000024 00000002672 12257055750 017776 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/accessor-roles.t000644 000765 000024 00000003203 12251110750 016317 0ustar00gknopstaff000000 000000 use strictures 1; 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); 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; Moo-1.004002/t/accessor-shortcuts.t000644 000765 000024 00000002055 12216242004 017234 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/accessor-trigger.t000644 000765 000024 00000003155 12257055750 016662 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use lib "t/lib"; use ComplexWriter; 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'; ComplexWriter->test_with("trigger"); done_testing; Moo-1.004002/t/accessor-weaken-pre-5_8_3.t000644 000765 000024 00000000316 12255737500 020062 0ustar00gknopstaff000000 000000 use strictures 1; BEGIN { $ENV{MOO_TEST_PRE_583} = 1; } (my $real_test = __FILE__) =~ s/-pre-5_8_3//; unless (defined do $real_test) { die "$real_test: $@" if $@; die "$real_test: $!" if $!; } Moo-1.004002/t/accessor-weaken.t000644 000765 000024 00000004053 12257055750 016467 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Moo::_Utils; ok(Moo::_Utils::lt_5_8_3, "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.008003) { 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.012000) { 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; Moo-1.004002/t/buildall-subconstructor.t000644 000765 000024 00000003232 12216242004 020261 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/buildall.t000644 000765 000024 00000002634 12216242004 015171 0ustar00gknopstaff000000 000000 use strictures 1; 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'); done_testing; Moo-1.004002/t/buildargs-error.t000644 000765 000024 00000000570 12216242004 016501 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/buildargs.t000644 000765 000024 00000006017 12257055750 015373 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package Qux; use Moo; has bar => ( is => "rw" ); has baz => ( is => "rw" ); package Quux; use Moo; extends qw(Qux); } { package t::non_moo; sub new { my ($class, $arg) = @_; bless { attr => $arg }, $class; } sub attr { shift->{attr} } package t::ext_non_moo::with_attr; use Moo; extends qw( t::non_moo ); 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 = t::non_moo->new( 'bar' ); my $ext_non_moo = t::ext_non_moo::with_attr->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; } eval { NoAttr->BUILDARGS( 37 ); }; like( $@, qr/Single parameters to new\(\) must be a HASH ref/, "default BUILDARGS requires a list or a HASH ref" ); my $noattr = NoAttr->new({ foo => 'bar' }); is $noattr->{foo}, 'bar', 'without attributes, all params are stored'; done_testing; Moo-1.004002/t/compose-non-role.t000644 000765 000024 00000000372 12251110750 016573 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/compose-roles.t000644 000765 000024 00000005452 12251110750 016172 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; { package One; use Role::Tiny; around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; package Two; use Role::Tiny; around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; package Three; use Role::Tiny; around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; package Four; use Role::Tiny; around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; package Base; sub foo { __PACKAGE__ } } foreach my $combo ( [ qw(One Two Three Four) ], [ qw(Two Four Three) ], [ qw(One Two) ] ) { my $combined = Role::Tiny->create_class_with_roles('Base', @$combo); is_deeply( [ $combined->foo ], [ reverse(@$combo), 'Base' ], "${combined} ok" ); my $object = bless({}, 'Base'); Role::Tiny->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'; done_testing; Moo-1.004002/t/demolish-basics.t000644 000765 000024 00000001537 12216242004 016450 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/demolish-bugs-eats_exceptions.t000644 000765 000024 00000007102 12216242004 021331 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use FindBin; 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 => $FindBin::Bin ); }; ::is( $@, '', "... $pkg no error" ); ::isa_ok( $obj, $pkg ); ::isa_ok( $obj, 'Moo::Object' ); ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" ); } } done_testing; Moo-1.004002/t/demolish-bugs-eats_mini.t000644 000765 000024 00000002410 12216242004 020101 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/demolish-global_destruction.t000644 000765 000024 00000000746 12216242004 021070 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; { 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; } chomp(my $out = `$^X t/global-destruction-helper.pl`); is( $out, 'true', 'in_global_destruction state is passed to DEMOLISH properly (true)' ); done_testing; Moo-1.004002/t/extend-constructor.t000644 000765 000024 00000001007 12251110750 017245 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/extends-non-moo.t000644 000765 000024 00000002465 12217207473 016451 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package t::moo::extends_non_moo::base; sub new { my ($proto, $args) = @_; bless $args, $proto; } sub to_app { (shift)->{app}; } package t::moo::extends_non_moo::middle; use base qw(t::moo::extends_non_moo::base); sub wrap { my($class, $app) = @_; $class->new({app => $app}) ->to_app; } package t::moo::extends_non_moo::moo; use Moo; extends 't::moo::extends_non_moo::middle'; package t::moo::extends_non_moo::moo_with_attr; use Moo; extends 't::moo::extends_non_moo::middle'; has 'attr' => (is=>'ro'); package t::moo::extends_non_moo::second_level_moo; use Moo; extends 't::moo::extends_non_moo::moo_with_attr'; has 'attr2' => (is=>'ro'); } ok my $app = 100, 'prepared $app'; ok $app = t::moo::extends_non_moo::middle->wrap($app), '$app from $app'; is $app, 100, '$app still 100'; ok $app = t::moo::extends_non_moo::moo->wrap($app), '$app from $app'; is $app, 100, '$app still 100'; ok $app = t::moo::extends_non_moo::moo_with_attr->wrap($app), '$app from $app'; is $app, 100, '$app still 100'; ok $app = t::moo::extends_non_moo::second_level_moo->wrap($app), '$app from $app'; is $app, 100, '$app still 100'; done_testing(); Moo-1.004002/t/extends-role.t000644 000765 000024 00000000336 12216242004 016007 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/foreignbuildargs.t000644 000765 000024 00000002300 12251110750 016716 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package t::non_moo_strict; sub new { my ($class, $arg) = @_; die "invalid arguments: " . join(',', @_[2..$#_]) if @_ > 2; bless { attr => $arg }, $class; } sub attr { shift->{attr} } package t::ext_non_moo_strict::with_attr; use Moo; extends qw( t::non_moo_strict ); has 'attr2' => ( is => 'ro' ); sub FOREIGNBUILDARGS { my ($class, %args) = @_; return $args{attr}; } package t::ext_non_moo_strict::without_attr; use Moo; extends qw( t::non_moo_strict ); sub FOREIGNBUILDARGS { my ($class, %args) = @_; return $args{attr2}; } } my $non_moo = t::non_moo_strict->new( 'bar' ); my $ext_non_moo = t::ext_non_moo_strict::with_attr->new( attr => 'bar', attr2 => 'baz' ); my $ext_non_moo2 = t::ext_non_moo_strict::without_attr->new( attr => '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"; is $ext_non_moo2->attr, 'baz', "extended non-moo passes params"; done_testing; Moo-1.004002/t/global-destruction-helper.pl000644 000765 000024 00000000374 12216242004 020626 0ustar00gknopstaff000000 000000 use strictures 1; use lib 'lib'; no warnings 'once'; # work around 5.6.2 { package Foo; use Moo; sub DEMOLISH { my $self = shift; my ($igd) = @_; print $igd ? "true" : "false", "\n"; } } our $foo = Foo->new; Moo-1.004002/t/global_underscore.t000644 000765 000024 00000000341 12251110750 017064 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use lib qw(t/lib); use_ok('UnderscoreClass'); is( UnderscoreClass->c1, 'c1', ); is( UnderscoreClass->r1, 'r1', ); is( ClobberUnderscore::h1(), 'h1', ); done_testing; Moo-1.004002/t/has-array.t000644 000765 000024 00000002115 12251110750 015263 0ustar00gknopstaff000000 000000 use 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; Moo-1.004002/t/has-before-extends.t000644 000765 000024 00000000546 12216242004 017064 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/has-plus.t000644 000765 000024 00000001451 12257120152 015135 0ustar00gknopstaff000000 000000 use strictures 1; 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'); } 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 +'); done_testing; Moo-1.004002/t/init-arg.t000644 000765 000024 00000002452 12216242004 015111 0ustar00gknopstaff000000 000000 use strictures 1; 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", ); done_testing; Moo-1.004002/t/lazy_isa.t000644 000765 000024 00000003101 12251013510 015177 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/lib/000755 000765 000024 00000000000 12260624267 013773 5ustar00gknopstaff000000 000000 Moo-1.004002/t/load_module.t000644 000765 000024 00000000665 12251013467 015677 0ustar00gknopstaff000000 000000 # this test is replicated to t/load_module_role_tiny.t for Role::Tiny # work around RT#67692 use Moo::_Utils; use strictures 1; use Test::More; local @INC = (sub { return unless $_[1] eq 'Foo/Bar.pm'; my $source = "package Foo::Bar; sub baz { 1 } 1"; open my $fh, '<', \$source; $fh; }, @INC); { package Foo::Bar::Baz; sub quux { } } _load_module("Foo::Bar"); ok(eval { Foo::Bar->baz }, 'Loaded module ok'); done_testing; Moo-1.004002/t/load_module_error.t000644 000765 000024 00000000322 12216242004 017066 0ustar00gknopstaff000000 000000 use strictures; package load_module_error; use Test::More; use lib 't/lib'; eval "use sub_class;"; ok $@, "got a crash"; unlike $@, qr/Unknown error/, "it came with a useful error message"; done_testing; Moo-1.004002/t/load_module_role_tiny.t000644 000765 000024 00000000642 12251013467 017756 0ustar00gknopstaff000000 000000 # this test is replicated to t/load_module.t for Moo::_Utils use Role::Tiny (); use strictures 1; use Test::More; local @INC = (sub { return unless $_[1] eq 'Foo/Bar.pm'; my $source = "package Foo::Bar; sub baz { 1 } 1"; open my $fh, '<', \$source; $fh; }, @INC); { package Foo::Bar::Baz; sub quux { } } Role::Tiny::_load_module("Foo::Bar"); ok(eval { Foo::Bar->baz }, 'Loaded module ok'); done_testing; Moo-1.004002/t/method-generate-accessor.t000644 000765 000024 00000007247 12252212647 020270 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use Method::Generate::Accessor; use Sub::Quote 'quote_sub'; my $gen = Method::Generate::Accessor->new; { package Foo; use Moo; } { package WithOverload; use overload '&{}' => sub { sub { 5 } }, fallback => 1; sub new { bless {} } } $gen->generate_method('Foo' => 'one' => { is => 'ro' }); $gen->generate_method('Foo' => 'two' => { is => 'rw' }); like( exception { $gen->generate_method('Foo' => 'three' => {}) }, qr/Must have an is/, 'No is rejected' ); like( exception { $gen->generate_method('Foo' => 'three' => { is => 'purple' }) }, qr/Unknown is purple/, 'is purple rejected' ); is(exception { $gen->generate_method('Foo' => 'three' => { is => 'bare', predicate => 1 }); }, undef, 'generating bare accessor works'); ok(Foo->can('has_three'), 'bare accessor will still generate predicate'); like( exception { $gen->generate_method('Foo' => 'four' => { is => 'ro', coerce => 5 }) }, qr/Invalid coerce/, "coerce - scalar rejected" ); is( exception { $gen->generate_method('Foo' => 'four' => { is => 'ro', default => 5 }) }, undef, "default - non-ref scalar accepted" ); foreach my $setting (qw( default coerce )) { like( exception { $gen->generate_method('Foo' => 'five' => { allow_overwrite => 1, is => 'ro', $setting => [] }) }, qr/Invalid $setting/, "$setting - arrayref rejected" ); like( exception { $gen->generate_method('Foo' => 'five' => { allow_overwrite => 1, is => 'ro', $setting => Foo->new }) }, qr/Invalid $setting/, "$setting - non-code-convertible object rejected" ); is( exception { $gen->generate_method('Foo' => 'six' => { allow_overwrite => 1, is => 'ro', $setting => sub { 5 } }) }, undef, "$setting - coderef accepted" ); is( exception { $gen->generate_method('Foo' => 'seven' => { allow_overwrite => 1, is => 'ro', $setting => bless sub { 5 } => 'Blah' }) }, undef, "$setting - blessed sub accepted" ); is( exception { $gen->generate_method('Foo' => 'eight' => { allow_overwrite => 1, is => 'ro', $setting => WithOverload->new }) }, undef, "$setting - object with overloaded ->() accepted" ); like( exception { $gen->generate_method('Foo' => 'nine' => { allow_overwrite => 1, is => 'ro', $setting => bless {} => 'Blah' }) }, qr/Invalid $setting/, "$setting - object rejected" ); } is( exception { $gen->generate_method('Foo' => 'ten' => { is => 'ro', builder => '_build_ten' }) }, undef, 'builder - string accepted', ); is( exception { $gen->generate_method('Foo' => 'eleven' => { is => 'ro', builder => sub {} }) }, undef, 'builder - coderef accepted' ); like( exception { $gen->generate_method('Foo' => 'twelve' => { is => 'ro', builder => 'build:twelve' }) }, qr/Invalid builder/, 'builder - invalid name rejected', ); is( exception { $gen->generate_method('Foo' => 'thirteen' => { is => 'ro', builder => 'build::thirteen' }) }, undef, 'builder - fully-qualified name accepted', ); is( exception { $gen->generate_method('Foo' => 'fifteen' => { is => 'lazy', builder => sub {15} }) }, undef, 'builder - coderef accepted' ); is( exception { $gen->generate_method('Foo' => 'sixteen' => { is => 'lazy', builder => quote_sub q{ 16 } }) }, undef, 'builder - quote_sub accepted' ); my $foo = Foo->new(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'); done_testing; Moo-1.004002/t/method-generate-constructor.t000644 000765 000024 00000002643 12257060677 021057 0ustar00gknopstaff000000 000000 use strictures 1; 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/attribute can't be required with init_arg => undef/, 'required not allowed with init_arg undef' ); done_testing; Moo-1.004002/t/modify_lazy_handlers.t000644 000765 000024 00000000567 12257055750 017631 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use lib qw(t/lib); BEGIN { use_ok 'MooObjectWithDelegate' }; { package MooObjectWithDelegate; 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; Moo-1.004002/t/moo-accessors.t000644 000765 000024 00000001442 12216242004 016152 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { 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'); 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"); done_testing unless caller; Moo-1.004002/t/moo.t000644 000765 000024 00000002035 12251110750 014167 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { 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' }; } is(MyClass5->foo, 'foo with around', 'method modifier'); done_testing; Moo-1.004002/t/mutual-requires.t000644 000765 000024 00000001517 12251110750 016545 0ustar00gknopstaff000000 000000 use strict; use warnings FATAL => 'all'; 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; Moo-1.004002/t/no-moo.t000644 000765 000024 00000003470 12251013511 014602 0ustar00gknopstaff000000 000000 use strictures 1; 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'); { no warnings 'once'; 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'); { no warnings 'once'; is($GlobalConflict2::after, "has!", 'package global left alone'); } done_testing; Moo-1.004002/t/non-moo-extends.t000644 000765 000024 00000000354 12257120152 016434 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; { package ClassA; use Moo; has 'foo' => ( is => 'ro'); } { package ClassB; our @ISA = 'ClassA'; } package main; my $o = ClassB->new; isa_ok $o, 'ClassB'; done_testing; Moo-1.004002/t/not-both.t000644 000765 000024 00000001353 12251110750 015131 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; # Compile-time exceptions, so need stringy eval; hence not Test::Fatal. { local $@; ok !eval q { package ZZZ; use Role::Tiny; use Moo; 1; }, "can't import Moo into a Role::Tiny role"; like $@, qr{Cannot import Moo into a role}, " ... with correct error message"; } { local $@; ok !eval q { package XXX; use Moo; use Moo::Role; 1; }, "can't import Moo::Role into a Moo class"; like $@, qr{Cannot import Moo::Role into a Moo class}, " ... with correct error message"; } { local $@; ok !eval q { package YYY; use Moo::Role; use Moo; 1; }, "can't import Moo into a Moo role"; like $@, qr{Cannot import Moo into a role}, " ... with correct error message"; } done_testing; Moo-1.004002/t/overloaded-coderefs.t000644 000765 000024 00000003746 12251110750 017323 0ustar00gknopstaff000000 000000 use strict; use warnings; 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; Moo-1.004002/t/sub-and-handles.t000644 000765 000024 00000003140 12251110750 016340 0ustar00gknopstaff000000 000000 use strictures 1; 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 A; use Moo; extends 'ConsumesDelegateToBar'; with 'Does::OverrideDelegate'; has '+_barrer' => ( is => 'rw' ); package B; use Moo; extends 'ConsumesDelegateToBar'; sub _bar { 'extended' } has '+_barrer' => ( is => 'rw' ); package D; use Moo; extends 'ConsumesDelegateToBar'; sub _bar { 'extended' } has '+_barrer' => ( is => 'rw', handles => { _baz => 'bar' }, ); package C; use Moo; extends 'ConsumesDelegateToBar'; with 'Does::OverrideDelegate'; has '+_barrer' => ( is => 'rw', handles => { _baz => 'bar' }, ); } is(A->new->_bar, 'extended', 'overriding delegate method with role works'); is(D->new->_bar, 'extended', '... even when you specify other delegates in subclass'); is(D->new->_baz, 'unextended!', '... and said other delegate still works'); is(B->new->_bar, 'extended', 'overriding delegate method directly works'); is(C->new->_bar, 'extended', '... even when you specify other delegates in subclass'); is(C->new->_baz, 'unextended!', '... and said other delegate still works'); done_testing; Moo-1.004002/t/sub-defer-threads.t000644 000765 000024 00000001241 12251110750 016677 0ustar00gknopstaff000000 000000 use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } } use threads; use strictures 1; use Test::More; use Sub::Defer; my %made; my $one_defer = defer_sub 'Foo::one' => sub { die "remade - wtf" if $made{'Foo::one'}; $made{'Foo::one'} = sub { 'one' } }; is(threads->create(sub { my $info = Sub::Defer::defer_info($one_defer); $info && $info->[0]; })->join, 'Foo::one', 'able to retrieve info in thread'); is(threads->create(sub { undefer_sub($one_defer); $made{'Foo::one'} && $made{'Foo::one'} == \&Foo::one && 1234; })->join, 1234, 'able to undefer in thread'); done_testing; Moo-1.004002/t/sub-defer.t000644 000765 000024 00000003767 12260341204 015266 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use Sub::Defer; my %made; my $one_defer = defer_sub 'Foo::one' => sub { die "remade - wtf" if $made{'Foo::one'}; $made{'Foo::one'} = sub { 'one' } }; my $two_defer = defer_sub 'Foo::two' => sub { die "remade - wtf" if $made{'Foo::two'}; $made{'Foo::two'} = sub { 'two' } }; is($one_defer, \&Foo::one, 'one defer installed'); is($two_defer, \&Foo::two, 'two defer installed'); is($one_defer->(), 'one', 'one defer runs'); is($made{'Foo::one'}, \&Foo::one, 'one made'); is($made{'Foo::two'}, undef, 'two not made'); is($one_defer->(), 'one', 'one (deferred) still runs'); is(Foo->one, 'one', 'one (undeferred) runs'); is(my $two_made = undefer_sub($two_defer), $made{'Foo::two'}, 'make two'); is exception { undefer_sub($two_defer) }, undef, "repeated undefer doesn't regenerate"; is($two_made, \&Foo::two, 'two installed'); is($two_defer->(), 'two', 'two (deferred) still runs'); is($two_made->(), 'two', 'two (undeferred) runs'); my $three = sub { 'three' }; is(undefer_sub($three), $three, 'undefer non-deferred is a no-op'); my $four_defer = defer_sub 'Foo::four' => sub { sub { 'four' } }; is($four_defer, \&Foo::four, 'four defer installed'); # somebody somewhere wraps up around the deferred installer no warnings qw/redefine/; my $orig = Foo->can('four'); *Foo::four = sub { $orig->() . ' with a twist'; }; is(Foo->four, 'four with a twist', 'around works'); is(Foo->four, 'four with a twist', 'around has not been destroyed by first invocation'); my $one_all_defer = defer_sub 'Foo::one_all' => sub { $made{'Foo::one_all'} = sub { 'one_all' } }; my $two_all_defer = defer_sub 'Foo::two_all' => sub { $made{'Foo::two_all'} = sub { 'two_all' } }; is( $made{'Foo::one_all'}, undef, 'one_all not made' ); is( $made{'Foo::two_all'}, undef, 'two_all not made' ); undefer_all(); is( $made{'Foo::one_all'}, \&Foo::one_all, 'one_all made by undefer_all' ); is( $made{'Foo::two_all'}, \&Foo::two_all, 'two_all made by undefer_all' ); done_testing; Moo-1.004002/t/sub-quote-threads.t000644 000765 000024 00000002047 12257101143 016756 0ustar00gknopstaff000000 000000 use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } } use threads; use strictures 1; use Test::More; use Sub::Quote; my $one = quote_sub q{ BEGIN { $::EVALED{'one'} = 1 } 42 }; my $one_code = quoted_from_sub($one)->[1]; my $two = quote_sub q{ BEGIN { $::EVALED{'two'} = 1 } 3 + $x++ } => { '$x' => \do { my $x = 0 } }; is(threads->create(sub { my $quoted = quoted_from_sub($one); $quoted && $quoted->[1]; })->join, $one_code, 'able to retrieve quoted sub in thread'); my $u_one = unquote_sub $one; is(threads->create(sub { $one->() })->join, 42, 'One (quoted version)'); is(threads->create(sub { $u_one->() })->join, 42, 'One (unquoted version)'); my $r = threads->create(sub { my @r; push @r, $two->(); push @r, unquote_sub($two)->(); push @r, $two->(); \@r; })->join; is($r->[0], 3, 'Two in thread (quoted version)'); is($r->[1], 4, 'Two in thread (unquoted version)'); is($r->[2], 5, 'Two in thread (quoted version again)'); done_testing; Moo-1.004002/t/sub-quote.t000644 000765 000024 00000003412 12257055750 015337 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; use Test::Fatal; use Sub::Quote; our %EVALED; my $one = quote_sub q{ BEGIN { $::EVALED{'one'} = 1 } 42 }; my $two = quote_sub q{ BEGIN { $::EVALED{'two'} = 1 } 3 + $x++ } => { '$x' => \do { my $x = 0 } }; ok(!keys %EVALED, 'Nothing evaled yet'); my $u_one = unquote_sub $one; is_deeply( [ sort keys %EVALED ], [ qw(one) ], 'subs one evaled' ); is($one->(), 42, 'One (quoted version)'); is($u_one->(), 42, 'One (unquoted version)'); is($two->(), 3, 'Two (quoted version)'); is(unquote_sub($two)->(), 4, 'Two (unquoted version)'); is($two->(), 5, 'Two (quoted version again)'); my $three = quote_sub 'Foo::three' => q{ $x = $_[1] if $_[1]; die +(caller(0))[3] if @_ > 2; return $x; } => { '$x' => \do { my $x = 'spoon' } }; is(Foo->three, 'spoon', 'get ok (named method)'); is(Foo->three('fork'), 'fork', 'set ok (named method)'); is(Foo->three, 'fork', 're-get ok (named method)'); like( exception { Foo->three(qw(full cutlery set)) }, qr/Foo::three/, 'exception contains correct name' ); quote_sub 'Foo::four' => q{ return 5; }; my $quoted = quoted_from_sub(\&Foo::four); like $quoted->[1], qr/return 5;/, 'can get quoted from installed sub'; Foo::four(); my $quoted2 = quoted_from_sub(\&Foo::four); is $quoted2->[1], undef, "can't get quoted from installed sub after undefer"; my $broken_quoted = quote_sub q{ return 5$; }; like( exception { $broken_quoted->() }, qr/Eval went very, very wrong/, "quoted sub with syntax error dies when called" ); sub in_main { 1 } is exception { quote_sub(q{ in_main(); })->(); }, undef, 'context preserved in quoted sub'; { no strict 'refs'; is exception { quote_sub(q{ my $foo = "some_variable"; $$foo; })->(); }, undef, 'hints are preserved'; } done_testing; Moo-1.004002/t/subconstructor.t000644 000765 000024 00000000314 12216242004 016471 0ustar00gknopstaff000000 000000 use strictures 1; use Test::More; { package SubCon1; use Moo; has foo => (is => 'ro'); package SubCon2; our @ISA = qw(SubCon1); } ok(SubCon2->new, 'constructor completes'); done_testing; Moo-1.004002/t/undef-bug.t000644 000765 000024 00000000277 12216242004 015256 0ustar00gknopstaff000000 000000 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"; Moo-1.004002/t/use-after-no.t000644 000765 000024 00000000762 12251013511 015704 0ustar00gknopstaff000000 000000 use strictures 1; 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; Moo-1.004002/t/lib/base_class.pm000644 000765 000024 00000000102 12216242004 016403 0ustar00gknopstaff000000 000000 use strictures; package base_class; use Moo; extends "marp"; 1; Moo-1.004002/t/lib/ClassicObject.pm000644 000765 000024 00000000175 12216242004 017026 0ustar00gknopstaff000000 000000 package ClassicObject; sub new { my ($class, %args) = @_; bless \%args, 'ClassicObject'; } sub connect { 'a' } 1; Moo-1.004002/t/lib/ClobberUnderscore.pm000644 000765 000024 00000000071 12216242004 017713 0ustar00gknopstaff000000 000000 package ClobberUnderscore; sub h1 { 'h1' }; undef $_; 1; Moo-1.004002/t/lib/ComplexWriter.pm000644 000765 000024 00000000564 12257055750 017143 0ustar00gknopstaff000000 000000 package ComplexWriter; use Moo; use Test::More; use Test::Fatal; has "t_$_" => ( is => 'rwp', $_ => sub { die 'triggered' }, writer => "set_t_$_", ) for qw(coerce isa trigger); sub test_with { my ($class, $option) = @_; my $writer = "set_t_$option"; like exception { __PACKAGE__->new->$writer( 4 ) }, qr/triggered/, "$option triggered via writer"; } 1; Moo-1.004002/t/lib/ExtRobot.pm000644 000765 000024 00000000070 12251013510 016053 0ustar00gknopstaff000000 000000 package ExtRobot; use Moo::Role; requires 'beep'; 1; Moo-1.004002/t/lib/MooObjectWithDelegate.pm000644 000765 000024 00000000726 12216242004 020470 0ustar00gknopstaff000000 000000 package MooObjectWithDelegate; use ClassicObject; 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'; }; 1; Moo-1.004002/t/lib/sub_class.pm000644 000765 000024 00000000105 12216242004 016265 0ustar00gknopstaff000000 000000 use strictures; package sub_class; use Moo; extends 'base_class'; Moo-1.004002/t/lib/UnderscoreClass.pm000644 000765 000024 00000000117 12216242004 017411 0ustar00gknopstaff000000 000000 package UnderscoreClass; use Moo; with qw(UnderscoreRole); sub c1 { 'c1' }; 1; Moo-1.004002/t/lib/UnderscoreRole.pm000644 000765 000024 00000000122 12216242004 017241 0ustar00gknopstaff000000 000000 package UnderscoreRole; use Moo::Role; use ClobberUnderscore; sub r1 { 'r1' }; 1; Moo-1.004002/maint/bump-version000755 000765 000024 00000002027 12257125306 016443 0ustar00gknopstaff000000 000000 #!/usr/bin/env perl use strict; use warnings FATAL => 'all'; use autodie; chomp(my $LATEST = qx(grep '^[0-9]' Changes | head -1 | awk '{print \$1}')); my @parts = split /\./, $LATEST; if (@parts == 2) { @parts[1,2] = $parts[1] =~ /(\d{1,3})(\d{1,3})/; } my $OLD_DECIMAL = sprintf('%i.%03i%03i', @parts); my %bump_part = (major => 0, minor => 1, bugfix => 2); my $bump_this = $bump_part{$ARGV[0]||'bugfix'}; die "no idea which part to bump - $ARGV[0] means nothing to me" unless defined($bump_this); my @new_parts = @parts; $new_parts[$bump_this]++; $new_parts[$_] = 0 for ($bump_this+1 .. 2); my $NEW_DECIMAL = sprintf('%i.%03i%03i', @new_parts); warn "Bumping $OLD_DECIMAL -> $NEW_DECIMAL\n"; for my $PM_FILE (qw( lib/Moo.pm lib/Moo/Role.pm lib/Sub/Defer.pm lib/Sub/Quote.pm )) { my $file = do { local (@ARGV, $/) = ($PM_FILE); <> }; $file =~ s/(?<=\$VERSION = ')${\quotemeta $OLD_DECIMAL}/${NEW_DECIMAL}/ or die "unable to bump version number in $PM_FILE"; open my $out, '>', $PM_FILE; print $out $file; } Moo-1.004002/maint/fulltest000755 000765 000024 00000000747 12257055750 015673 0ustar00gknopstaff000000 000000 #!/bin/sh TEST_DIRS='t xt' while [ "$#" -gt "0" ]; do case $1 in --cover) COVERAGE=1 ;; *) echo "Invalid option: $1" exit 1 ;; esac shift done if [ -n "$AUTHOR_TESTING" ] && [ "$AUTHOR_TESTING" -eq 0 ]; then TEST_DIRS='t' fi if [ -n "$COVERAGE" ] && [ "$COVERAGE" -ne 0 ]; then cover -delete -silent export HARNESS_PERL_SWITCHES='-MDevel::Cover=-ignore,^x?t/,-blib,0' fi prove -l $TEST_DIRS && MOO_XS_DISABLE=1 prove -l $TEST_DIRS Moo-1.004002/maint/Makefile.PL.include000644 000765 000024 00000000516 12251110750 017453 0ustar00gknopstaff000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar 0.001; use ExtUtils::MakeMaker 6.57_10 (); author 'mst - Matt S. Trout (cpan:MSTROUT) '; manifest_include t => 'global-destruction-helper.pl'; manifest_include bin => 'moo-outdated'; 1; Moo-1.004002/maint/travis-install000755 000765 000024 00000002071 12257055750 016775 0ustar00gknopstaff000000 000000 #!/bin/bash function clean_up { kill $PROG wait 2>/dev/null } export PERL_CPANM_OPT="--mirror http://www.cpan.org/" function cpanm_install { local dep="$1" printf "Installing (without testing) $dep ..." ( while true; do sleep 3 printf '.' done ) & local PROG=$! trap "clean_up $PROG; exit 1" SIGHUP SIGINT SIGTERM local OUT=$(cpanm --verbose --no-interactive --no-man-pages --notest $dep 2>&1 ) local STATUS=$? kill $PROG wait $PROG 2>/dev/null trap - SIGHUP SIGINT SIGTERM if [ $STATUS != 0 ]; then echo ' Failed!' echo "$OUT" exit $? fi echo ' Done' } for arg; do case $arg in --deps) AUTHOR_OPTS='' if [ -z "$AUTHOR_TESTING" ] || [ "$AUTHOR_TESTING" -ne 0 ]; then AUTHOR_OPTS='--with-recommends' fi DEPS="$DEPS $(cpanm --showdeps -q . --with-develop $AUTHOR_OPTS)" for dep in $DEPS; do case $dep in perl*) ;; *) cpanm_install $dep ;; esac done ;; *) cpanm_install $arg ;; esac done Moo-1.004002/maint/travis-perlbrew000644 000765 000024 00000001331 12260306270 017132 0ustar00gknopstaff000000 000000 BREWVER=${TRAVIS_PERL_VERSION/_*/} BREWOPTS= [[ "${TRAVIS_PERL_VERSION}_" =~ '_thr_' ]] && BREWOPTS="$BREWOPTS -Duseithreads" [[ "$(sed -n -E -e's/^5\.([0-9]+).*/\1/p' <<< $TRAVIS_PERL_VERSION)" -ge 14 ]] && BREWOPTS="$BREWOPTS -j 2" if ! perlbrew use | grep -q "Currently using $TRAVIS_PERL_VERSION"; then echo "Building perl $TRAVIS_PERL_VERSION..." PERLBUILD=$(perlbrew install --as $TRAVIS_PERL_VERSION --notest --noman --verbose $BREWOPTS $BREWVER 2>&1) perlbrew use $TRAVIS_PERL_VERSION if ! perlbrew use | grep -q "Currently using $TRAVIS_PERL_VERSION"; then echo "Unable to switch to $TRAVIS_PERL_VERSION - compilation failed...?" 1>&2 echo "$PERLBUILD" 1>&2 exit 1 fi fi perlbrew install-cpanm -f Moo-1.004002/lib/Method/000755 000765 000024 00000000000 12260624267 014750 5ustar00gknopstaff000000 000000 Moo-1.004002/lib/Moo/000755 000765 000024 00000000000 12260624267 014262 5ustar00gknopstaff000000 000000 Moo-1.004002/lib/Moo.pm000644 000765 000024 00000074021 12260624053 014615 0ustar00gknopstaff000000 000000 package Moo; use strictures 1; use Moo::_Utils; use B 'perlstring'; use Sub::Defer (); use Import::Into; our $VERSION = '1.004002'; $VERSION = eval $VERSION; require Moo::sification; our %MAKERS; sub _install_tracked { my ($target, $name, $code) = @_; $MAKERS{$target}{exports}{$name} = $code; _install_coderef "${target}::${name}" => "Moo::${name}" => $code; } sub import { my $target = caller; my $class = shift; _set_loaded(caller); strictures->import::into(1); if ($Role::Tiny::INFO{$target} and $Role::Tiny::INFO{$target}{is_role}) { die "Cannot import Moo into a role"; } $MAKERS{$target} ||= {}; _install_tracked $target => extends => sub { $class->_set_superclasses($target, @_); $class->_maybe_reset_handlemoose($target); return; }; _install_tracked $target => with => sub { require Moo::Role; Moo::Role->apply_roles_to_package($target, @_); $class->_maybe_reset_handlemoose($target); }; _install_tracked $target => has => sub { my $name_proto = shift; my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto; if (@_ % 2 != 0) { require Carp; Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto) . " attribute(s): even number of arguments expected, got " . scalar @_) } my %spec = @_; foreach my $name (@name_proto) { # Note that when multiple attributes specified, each attribute # needs a separate \%specs hashref my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec; $class->_constructor_maker_for($target) ->register_attribute_specs($name, $spec_ref); $class->_accessor_maker_for($target) ->generate_method($target, $name, $spec_ref); $class->_maybe_reset_handlemoose($target); } return; }; foreach my $type (qw(before after around)) { _install_tracked $target => $type => sub { require Class::Method::Modifiers; _install_modifier($target, $type, @_); return; }; } return if $MAKERS{$target}{is_class}; # already exported into this package my $stash = _getstash($target); my @not_methods = map { *$_{CODE}||() } grep !ref($_), values %$stash; @{$MAKERS{$target}{not_methods}={}}{@not_methods} = @not_methods; $MAKERS{$target}{is_class} = 1; { no strict 'refs'; @{"${target}::ISA"} = do { require Moo::Object; ('Moo::Object'); } unless @{"${target}::ISA"}; } if ($INC{'Moo/HandleMoose.pm'}) { Moo::HandleMoose::inject_fake_metaclass_for($target); } } sub unimport { my $target = caller; _unimport_coderefs($target, $MAKERS{$target}); } sub _set_superclasses { my $class = shift; my $target = shift; foreach my $superclass (@_) { _load_module($superclass); if ($INC{"Role/Tiny.pm"} && $Role::Tiny::INFO{$superclass}) { require Carp; Carp::croak("Can't extend role '$superclass'"); } } # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA @{*{_getglob("${target}::ISA")}{ARRAY}} = @_; if (my $old = delete $Moo::MAKERS{$target}{constructor}) { delete _getstash($target)->{new}; Moo->_constructor_maker_for($target) ->register_attribute_specs(%{$old->all_attribute_specs}); } elsif (!$target->isa('Moo::Object')) { Moo->_constructor_maker_for($target); } no warnings 'once'; # piss off. -- mst $Moo::HandleMoose::MOUSE{$target} = [ grep defined, map Mouse::Util::find_meta($_), @_ ] if Mouse::Util->can('find_meta'); } sub _maybe_reset_handlemoose { my ($class, $target) = @_; if ($INC{"Moo/HandleMoose.pm"}) { Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target); } } sub _accessor_maker_for { my ($class, $target) = @_; return unless $MAKERS{$target}; $MAKERS{$target}{accessor} ||= do { my $maker_class = do { if (my $m = do { if (my $defer_target = (Sub::Defer::defer_info($target->can('new'))||[])->[0] ) { my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/); $MAKERS{$pkg} && $MAKERS{$pkg}{accessor}; } else { undef; } }) { ref($m); } else { require Method::Generate::Accessor; 'Method::Generate::Accessor' } }; $maker_class->new; } } sub _constructor_maker_for { my ($class, $target, $select_super) = @_; return unless $MAKERS{$target}; $MAKERS{$target}{constructor} ||= do { require Method::Generate::Constructor; require Sub::Defer; my ($moo_constructor, $con); if ($select_super && $MAKERS{$select_super}) { $moo_constructor = 1; $con = $MAKERS{$select_super}{constructor}; } else { my $t_new = $target->can('new'); if ($t_new) { if ($t_new == Moo::Object->can('new')) { $moo_constructor = 1; } elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) { my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/); if ($MAKERS{$pkg}) { $moo_constructor = 1; $con = $MAKERS{$pkg}{constructor}; } } } else { $moo_constructor = 1; # no other constructor, make a Moo one } } ($con ? ref($con) : 'Method::Generate::Constructor') ->new( package => $target, accessor_generator => $class->_accessor_maker_for($target), $moo_constructor ? ( $con ? (construction_string => $con->construction_string) : () ) : ( construction_builder => sub { '$class->'.$target.'::SUPER::new(' .($target->can('FOREIGNBUILDARGS') ? '$class->FOREIGNBUILDARGS(@_)' : '@_') .')' }, ), subconstructor_handler => ( ' if ($Moo::MAKERS{$class}) {'."\n" .' '.$class.'->_constructor_maker_for($class,'.perlstring($target).');'."\n" .' return $class->new(@_)'.";\n" .' } elsif ($INC{"Moose.pm"} and my $meta = Class::MOP::get_metaclass_by_name($class)) {'."\n" .' return $meta->new_object($class->BUILDARGS(@_));'."\n" .' }'."\n" ), ) ->install_delayed ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}}) } } sub _concrete_methods_of { my ($me, $role) = @_; my $makers = $MAKERS{$role}; # grab role symbol table my $stash = _getstash($role); # reverse so our keys become the values (captured coderefs) in case # they got copied or re-used since my $not_methods = { reverse %{$makers->{not_methods}||{}} }; +{ # grab all code entries that aren't in the not_methods list map { my $code = *{$stash->{$_}}{CODE}; ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code) } grep !ref($stash->{$_}), keys %$stash }; } 1; __END__ =pod =encoding utf-8 =head1 NAME Moo - Minimalist Object Orientation (with Moose compatibility) =head1 SYNOPSIS package Cat::Food; use Moo; use namespace::clean; sub feed_lion { my $self = shift; my $amount = shift || 1; $self->pounds( $self->pounds - $amount ); } has taste => ( is => 'ro', ); has brand => ( is => 'ro', isa => sub { die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ' }, ); has pounds => ( is => 'rw', isa => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 }, ); 1; And elsewhere: my $full = Cat::Food->new( taste => 'DELICIOUS.', brand => 'SWEET-TREATZ', pounds => 10, ); $full->feed_lion; say $full->pounds; =head1 DESCRIPTION This module is an extremely light-weight subset of L optimised for rapid startup and "pay only for what you use". It also avoids depending on any XS modules to allow simple deployments. The name C is based on the idea that it provides almost -- but not quite -- two thirds of L. Unlike L this module does not aim at full compatibility with L's surface syntax, preferring instead of provide full interoperability via the metaclass inflation capabilities described in L. For a full list of the minor differences between L and L's surface syntax, see L. =head1 WHY MOO EXISTS If you want a full object system with a rich Metaprotocol, L is already wonderful. However, sometimes you're writing a command line script or a CGI script where fast startup is essential, or code designed to be deployed as a single file via L, or you're writing a CPAN module and you want it to be usable by people with those constraints. I've tried several times to use L but it's 3x the size of Moo and takes longer to load than most of my Moo based CGI scripts take to run. If you don't want L, you don't want "less metaprotocol" like L, you want "as little as possible" -- which means "no metaprotocol", which is what Moo provides. Better still, if you install and load L, we set up metaclasses for your L classes and L roles, so you can use them in L code without ever noticing that some of your codebase is using L. Hence, Moo exists as its name -- Minimal Object Orientation -- with a pledge to make it smooth to upgrade to L when you need more than minimal features. =head1 MOO AND MOOSE If L detects L being loaded, it will automatically register metaclasses for your L and L packages, so you should be able to use them in L code without anybody ever noticing you aren't using L everywhere. L will also create L for classes and roles, so that C<< isa => 'MyClass' >> and C<< isa => 'MyRole' >> work the same as for L classes and roles. Extending a L class or consuming a L will also work. So will extending a L class or consuming a L - but note that we don't provide L metaclasses or metaroles so the other way around doesn't work. This feature exists for L users porting to L; enabling L users to use L classes is not a priority for us. This means that there is no need for anything like L for Moo code - Moo and Moose code should simply interoperate without problem. To handle L code, you'll likely need an empty Moo role or class consuming or extending the L stuff since it doesn't register true L metaclasses like L does. If you want types to be upgraded to the L types, use L and install the L library to match the L library you're using - L will load the L library and use that type for the newly created metaclass. 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 currently global and turns the mechanism off entirely so don't put this in library code. =head1 MOO AND CLASS::XSACCESSOR If a new enough version of L is available, it will be used to generate simple accessors, readers, and writers for a speed boost. Simple accessors are those without lazy defaults, type checks/coercions, or triggers. Readers and writers generated by L will behave slightly differently: they will reject attempts to call them with the incorrect number of parameters. =head1 MOO VERSUS ANY::MOOSE L will load L normally, and L in a program using L - which theoretically allows you to get the startup time of L without disadvantaging L users. Sadly, this doesn't entirely work, since the selection is load order dependent - L's metaclass inflation system explained above in L is significantly more reliable. So if you want to write a CPAN module that loads fast or has only pure perl dependencies but is also fully usable by L users, you should be using L. For a full explanation, see the article L which explains the differing strategies in more detail and provides a direct example of where L succeeds and L fails. =head1 IMPORTED METHODS =head2 new Foo::Bar->new( attr1 => 3 ); or Foo::Bar->new({ attr1 => 3 }); =head2 BUILDARGS sub BUILDARGS { my ( $class, @args ) = @_; unshift @args, "attr1" if @args % 2 == 1; return { @args }; }; Foo::Bar->new( 3 ); The default implementation of this method accepts a hash or hash reference of named parameters. If it receives a single argument that isn't a hash reference it throws an error. You can override this method in your class to handle other types of options passed to the constructor. This method should always return a hash reference of named options. =head2 FOREIGNBUILDARGS If you are inheriting from a non-Moo class, the arguments passed to the parent class constructor can be manipulated by defining a C method. It will receive the same arguments as C, and should return a list of arguments to pass to the parent class constructor. =head2 BUILD Define a C method on your class and the constructor will automatically call the C method from parent down to child after the object has been instantiated. Typically this is used for object validation or possibly logging. =head2 DEMOLISH If you have a C method anywhere in your inheritance hierarchy, a C method is created on first object construction which will call C<< $instance->DEMOLISH($in_global_destruction) >> for each C method from child upwards to parents. Note that the C method is created on first construction of an object of your class in order to not add overhead to classes without C methods; this may prove slightly surprising if you try and define your own. =head2 does if ($foo->does('Some::Role1')) { ... } Returns true if the object composes in the passed role. =head1 IMPORTED SUBROUTINES =head2 extends extends 'Parent::Class'; Declares base class. Multiple superclasses can be passed for multiple inheritance (but please use roles instead). The class will be loaded, however no errors will be triggered if it can't be found and there are already subs in the class. Calling extends more than once will REPLACE your superclasses, not add to them like 'use base' would. =head2 with with 'Some::Role1'; or with 'Some::Role1', 'Some::Role2'; Composes one or more L (or L) roles into the current class. An error will be raised if these roles have conflicting methods. The roles will be loaded using the same mechansim as C uses. =head2 has has attr => ( is => 'ro', ); Declares an attribute for the class. package Foo; use Moo; has 'attr' => ( is => 'ro' ); package Bar; use Moo; extends 'Foo'; has '+attr' => ( default => sub { "blah" }, ); Using the C<+> notation, it's possible to override an attribute. The options for C are as follows: =over 2 =item * is B, may be C, C, C or C. C generates an accessor that dies if you attempt to write to it - i.e. a getter only - by defaulting C to the name of the attribute. C generates a reader like C, but also sets C to 1 and C to C<_build_${attribute_name}> to allow on-demand generated attributes. This feature was my attempt to fix my incompetence when originally designing C, and is also implemented by L. There is, however, nothing to stop you using C and C yourself with C or C - it's just that this isn't generally a good idea so we don't provide a shortcut for it. C generates a reader like C, but also sets C to C<_set_${attribute_name}> for attributes that are designed to be written from inside of the class, but read-only from outside. This feature comes from L. C generates a normal getter/setter by defaulting C to the name of the attribute. =item * isa Takes a coderef which is meant to validate the attribute. Unlike L, Moo does not include a basic type system, so instead of doing C<< isa => 'Num' >>, one should do isa => sub { die "$_[0] is not a number!" unless looks_like_number $_[0] }, Note that the return value is ignored, only whether the sub lives or dies matters. L Since L does B run the C check before C if a coercion subroutine has been supplied, C checks are not structural to your code and can, if desired, be omitted on non-debug builds (although if this results in an uncaught bug causing your program to break, the L authors guarantee nothing except that you get to keep both halves). If you want L style named types, look at L. To cause your C entries to be automatically mapped to named L objects (rather than the default behaviour of creating an anonymous type), set: $Moo::HandleMoose::TYPE_MAP{$isa_coderef} = sub { require MooseX::Types::Something; return MooseX::Types::Something::TypeName(); }; Note that this example is purely illustrative; anything that returns a L object or something similar enough to it to make L happy is fine. =item * 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 L will always fire your coercion: this is to permit C entries to be used purely for bug trapping, whereas coercions are always structural to your code. We do, however, apply any supplied C check after the coercion has run to ensure that it returned a valid value. L =item * handles Takes a string handles => 'RobotRole' Where C is a role (L) that defines an interface which becomes the list of methods to handle. Takes a list of methods handles => [ qw( one two ) ] Takes a hashref handles => { un => 'one', } =item * C Takes a coderef which will get called any time the attribute is set. This includes the constructor, but not default or built values. Coderef will be invoked against the object with the new value as an argument. If you set this to just C<1>, it generates a trigger which calls the C<_trigger_${attr_name}> method on C<$self>. This feature comes from L. Note that Moose also passes the old value, if any; this feature is not yet supported. L =item * C Takes a coderef which will get called with $self as its only argument to populate an attribute if no value is supplied to the constructor - or if the attribute is lazy, when the attribute is first retrieved if no value has yet been provided. If a simple scalar is provided, it will be inlined as a string. Any non-code reference (hash, array) will result in an error - for that case instead use a code reference that returns the desired value. Note that if your default is fired during new() there is no guarantee that other attributes have been populated yet so you should not rely on their existence. L =item * C Takes a method name which will return true if an attribute has a value. If you set this to just C<1>, the predicate is automatically named C if your attribute's name does not start with an underscore, or C<_has_${attr_name_without_the_underscore}> if it does. This feature comes from L. =item * C Takes a method name which will be called to create the attribute - functions exactly like default except that instead of calling $default->($self); Moo will call $self->$builder; The following features come from L: If you set this to just C<1>, the builder is automatically named C<_build_${attr_name}>. If you set this to a coderef or code-convertible object, that variable will be installed under C<$class::_build_${attr_name}> and the builder set to the same name. =item * C Takes a method name which will clear the attribute. If you set this to just C<1>, the clearer is automatically named C if your attribute's name does not start with an underscore, or <_clear_${attr_name_without_the_underscore}> if it does. This feature comes from L. =item * C B. Set this if you want values for the attribute to be grabbed lazily. This is usually a good idea if you have a L which requires another attribute to be set. =item * C B. Set this if the attribute must be passed on instantiation. =item * C The value of this attribute will be the name of the method to get the value of the attribute. If you like Java style methods, you might set this to C =item * C The value of this attribute will be the name of the method to set the value of the attribute. If you like Java style methods, you might set this to C. =item * C B. Set this if you want the reference that the attribute contains to be weakened; use this when circular references are possible, which will cause leaks. =item * C Takes the name of the key to look for at instantiation time of the object. A common use of this is to make an underscored attribute have a non-underscored initialization name. C means that passing the value in on instantiation is ignored. =item * C Takes either a coderef or array of coderefs which is meant to transform the given attributes specifications if necessary when upgrading to a Moose role or class. You shouldn't need this by default, but is provided as a means of possible extensibility. =back =head2 before before foo => sub { ... }; See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full documentation. =head2 around around foo => sub { ... }; See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full documentation. =head2 after after foo => sub { ... }; See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full documentation. =head1 SUB QUOTE AWARE L allows us to create coderefs that are "inlineable," giving us a handy, XS-free speed boost. Any option that is L aware can take advantage of this. To do this, you can write use Sub::Quote; use Moo; use namespace::clean; has foo => ( is => 'ro', isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 }) ); which will be inlined as do { local @_ = ($_[0]->{foo}); die "Not <3" unless $_[0] < 3; } or to avoid localizing @_, has foo => ( is => 'ro', isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 }) ); which will be inlined as do { my ($val) = ($_[0]->{foo}); die "Not <3" unless $val < 3; } See L for more information, including how to pass lexical captures that will also be compiled into the subroutine. =head1 CLEANING UP IMPORTS L will not clean up imported subroutines for you; you will have to do that manually. The recommended way to do this is to declare your imports first, then C, then C. Anything imported before L will be scrubbed. Anything imported or declared after will be still be available. package Record; use Digest::MD5 qw(md5_hex); use Moo; use namespace::clean; has name => (is => 'ro', required => 1); has id => (is => 'lazy'); sub _build_id { my ($self) = @_; return md5_hex($self->name); } 1; If you were to import C after L you would be able to call C<< ->md5_hex() >> on your C instances (and it probably wouldn't do what you expect!). Ls behave slightly differently. Since their methods are composed into the consuming class, they can do a little more for you automatically. As long as you declare your imports before calling C, those imports and the ones L itself provides will not be composed into consuming classes, so there's usually no need to use L. B:> If you're coming to Moo from the Moose world, you may be accustomed to using L in all your packages. This is not recommended for L packages, because L will inflate your class to a full L class. It'll work, but you will lose the benefits of L. Instead you are recommended to just use L. =head1 INCOMPATIBILITIES WITH MOOSE There is no built-in type system. C is verified with a coderef; if you need complex types, just make a library of coderefs, or better yet, functions that return quoted subs. L provides a similar API to L so that you can write has days_to_live => (is => 'ro', isa => Int); and have it work with both; it is hoped that providing only subrefs as an API will encourage the use of other type systems as well, since it's probably the weakest part of Moose design-wise. C is not supported in core since the author considers it to be a bad idea and Moose best practices recommend avoiding it. Meanwhile C or C are more likely to be able to fulfill your needs. There is no meta object. If you need this level of complexity you wanted L - Moo succeeds at being small because it explicitly does not provide a metaprotocol. However, if you load L, then Class::MOP::class_of($moo_class_or_role) will return an appropriate metaclass pre-populated by L. No support for C, C, C, or C - the author considers augment to be a bad idea, and override can be translated: override foo => sub { ... super(); ... }; around foo => sub { my ($orig, $self) = (shift, shift); ... $self->$orig(@_); ... }; The C method is not provided by default. The author suggests loading L into C (via C for example) and using C<$obj-E$::Dwarn()> instead. L only supports coderefs and plain scalars, because passing a hash or array reference as a default is almost always incorrect since the value is then shared between all objects using that default. C is not supported; you are instead encouraged to use the C<< is => 'lazy' >> option supported by L and L. C is not supported since the author considers it a bad idea and it has been considered best practice to avoid it for some time. C will show up in a L metaclass created from your class but is otherwise ignored. Then again, L ignores it as well, so this is arguably not an incompatibility. Since C does not require C to be defined but L does require it, the metaclass inflation for coerce alone is a trifle insane and if you attempt to subtype the result will almost certainly break. C is not triggered if your class does not have any attributes. Without attributes, C return value would be ignored, so we just skip calling the method instead. Handling of warnings: when you C we enable FATAL warnings, and some several extra pragmas when used in development: L, L, and L. See the L documentation for the details on this. A similar invocation for L would be: use Moose; use warnings FATAL => "all"; Additionally, L supports a set of attribute option shortcuts intended to reduce common boilerplate. The set of shortcuts is the same as in the L module L as of its version 0.009+. So if you: package MyClass; use Moo; The nearest L invocation would be: package MyClass; use Moose; use warnings FATAL => "all"; use MooseX::AttributeShortcuts; or, if you're inheriting from a non-Moose class, package MyClass; use Moose; use MooseX::NonMoose; use warnings FATAL => "all"; use MooseX::AttributeShortcuts; Finally, Moose requires you to call __PACKAGE__->meta->make_immutable; at the end of your class to get an inlined (i.e. not horribly slow) constructor. Moo does it automatically the first time ->new is called on your class. (C is a no-op in Moo to ease migration.) An extension L exists to ease translating Moose packages to Moo by providing a more Moose-like interface. =head1 SUPPORT Users' IRC: #moose on irc.perl.org =for html (click for instant chatroom login) Development and contribution IRC: #web-simple on irc.perl.org =for html (click for instant chatroom login) Bugtracker: L Git repository: L Git browser: L =head1 AUTHOR mst - Matt S. Trout (cpan:MSTROUT) =head1 CONTRIBUTORS dg - David Leadbeater (cpan:DGL) frew - Arthur Axel "fREW" Schmidt (cpan:FREW) hobbs - Andrew Rodland (cpan:ARODLAND) jnap - John Napiorkowski (cpan:JJNAPIORK) ribasushi - Peter Rabbitson (cpan:RIBASUSHI) chip - Chip Salzenberg (cpan:CHIPS) ajgb - Alex J. G. Burzyński (cpan:AJGB) doy - Jesse Luehrs (cpan:DOY) perigrin - Chris Prather (cpan:PERIGRIN) Mithaldu - Christian Walde (cpan:MITHALDU) ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) tobyink - Toby Inkster (cpan:TOBYINK) haarg - Graham Knop (cpan:HAARG) mattp - Matt Phillips (cpan:MATTP) bluefeet - Aran Deltac (cpan:BLUEFEET) =head1 COPYRIGHT Copyright (c) 2010-2011 the Moo L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. See L. =cut Moo-1.004002/lib/oo.pm000644 000765 000024 00000001037 12216242004 014466 0ustar00gknopstaff000000 000000 package oo; use strictures 1; use Moo::_Utils; 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; Moo-1.004002/lib/Sub/000755 000765 000024 00000000000 12260624267 014261 5ustar00gknopstaff000000 000000 Moo-1.004002/lib/Sub/Defer.pm000644 000765 000024 00000006367 12260624053 015651 0ustar00gknopstaff000000 000000 package Sub::Defer; use strictures 1; use base qw(Exporter); use Moo::_Utils; use Scalar::Util qw(weaken); our $VERSION = '1.004002'; $VERSION = eval $VERSION; our @EXPORT = qw(defer_sub undefer_sub undefer_all); our %DEFERRED; sub undefer_sub { my ($deferred) = @_; my ($target, $maker, $undeferred_ref) = @{ $DEFERRED{$deferred}||return $deferred }; return ${$undeferred_ref} if ${$undeferred_ref}; ${$undeferred_ref} = my $made = $maker->(); # make sure the method slot has not changed since deferral time if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') { no warnings 'redefine'; # I believe $maker already evals with the right package/name, so that # _install_coderef calls are not necessary --ribasushi *{_getglob($target)} = $made; } weaken($DEFERRED{$made} = $DEFERRED{$deferred}); return $made; } sub undefer_all { undefer_sub($_) for keys %DEFERRED; return; } sub defer_info { my ($deferred) = @_; $DEFERRED{$deferred||''}; } sub defer_sub { my ($target, $maker) = @_; my $undeferred; my $deferred_info; my $deferred = sub { $undeferred ||= undefer_sub($deferred_info->[3]); goto &$undeferred; }; $deferred_info = [ $target, $maker, \$undeferred, $deferred ]; weaken($DEFERRED{$deferred} = $deferred_info); _install_coderef($target => $deferred) if defined $target; return $deferred; } sub CLONE { %DEFERRED = map { defined $_ ? ($_->[3] => $_) : () } values %DEFERRED; weaken($_) for values %DEFERRED; } 1; __END__ =head1 NAME Sub::Defer - defer generation of subroutines until they are first called =head1 SYNOPSIS use Sub::Defer; my $deferred = defer_sub 'Logger::time_since_first_log' => sub { my $t = time; sub { time - $t }; }; Logger->time_since_first_log; # returns 0 and replaces itself Logger->time_since_first_log; # returns time - $t =head1 DESCRIPTION These subroutines provide the user with a convenient way to defer creation of subroutines and methods until they are first called. =head1 SUBROUTINES =head2 defer_sub my $coderef = defer_sub $name => sub { ... }; This subroutine returns a coderef that encapsulates the provided sub - when it is first called, the provided sub is called and is -itself- expected to return a subroutine which will be goto'ed to on subsequent calls. If a name is provided, this also installs the sub as that name - and when the subroutine is undeferred will re-install the final version for speed. =head2 undefer_sub my $coderef = undefer_sub \&Foo::name; If the passed coderef has been L this will "undefer" it. If the passed coderef has not been deferred, this will just return it. If this is confusing, take a look at the example in the L. =head2 undefer_all undefer_all(); This will undefer all defered subs in one go. This can be very useful in a forking environment where child processes would each have to undefer the same subs. By calling this just before you start forking children you can undefer all currently deferred subs in the parent so that the children do not have to do it. =head1 SUPPORT See L for support and contact information. =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Moo-1.004002/lib/Sub/Quote.pm000644 000765 000024 00000016554 12260624053 015720 0ustar00gknopstaff000000 000000 package Sub::Quote; use strictures 1; sub _clean_eval { eval $_[0] } use Sub::Defer; use B 'perlstring'; use Scalar::Util qw(weaken); use base qw(Exporter); our $VERSION = '1.004002'; $VERSION = eval $VERSION; our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); our %QUOTED; our %WEAK_REFS; sub capture_unroll { my ($from, $captures, $indent) = @_; join( '', map { /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_"; (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n}; } keys %$captures ); } sub inlinify { my ($code, $args, $extra, $local) = @_; my $do = 'do { '.($extra||''); if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) { $do .= $1; } my $assign = ''; if (my ($code_args) = $code =~ /^\s*my\s*\(([^)]+)\)\s*=\s*\@_;$/s) { if ($code_args ne $args) { $assign = 'my ('.$code_args.') = ('.$args.'); '; } } elsif ($local || $args ne '@_') { $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); '; } $do.$assign.$code.' }'; } sub quote_sub { # HOLY DWIMMERY, BATMAN! # $name => $code => \%captures => \%options # $name => $code => \%captures # $name => $code # $code => \%captures => \%options # $code my $options = (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH') ? pop : {}; my $captures = ref($_[-1]) eq 'HASH' ? pop : undef; undef($captures) if $captures && !keys %$captures; my $code = pop; my $name = $_[0]; my ($package, $hints, $bitmask, $hintshash) = (caller(0))[0,8,9,10]; my $context ="package $package;\n" ."BEGIN {\n" ." \$^H = ".B::perlstring($hints).";\n" ." \${^WARNING_BITS} = ".B::perlstring($bitmask).";\n" ." \%^H = (\n" . join('', map " ".B::perlstring($_)." => ".B::perlstring($hintshash->{$_}).",", keys %$hintshash) ." );\n" ."}\n"; $code = "$context$code"; my $quoted_info; my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { unquote_sub($quoted_info->[4]); }; $quoted_info = [ $name, $code, $captures, undef, $deferred ]; weaken($QUOTED{$deferred} = $quoted_info); return $deferred; } sub quoted_from_sub { my ($sub) = @_; $QUOTED{$sub||''}; } sub unquote_sub { my ($sub) = @_; unless ($QUOTED{$sub}[3]) { my ($name, $code, $captures) = @{$QUOTED{$sub}}; my $make_sub = "{\n"; my %captures = $captures ? %$captures : (); $captures{'$_QUOTED'} = \$QUOTED{$sub}; $make_sub .= capture_unroll("\$_[1]", \%captures, 2); $make_sub .= ( $name # disable the 'variable $x will not stay shared' warning since # we're not letting it escape from this scope anyway so there's # nothing trying to share it ? " no warnings 'closure';\n sub ${name} {\n" : " \$_QUOTED->[3] = sub {\n" ); $make_sub .= $code; $make_sub .= " }".($name ? '' : ';')."\n"; if ($name) { $make_sub .= " \$_QUOTED->[3] = \\&${name}\n"; } $make_sub .= "}\n1;\n"; $ENV{SUB_QUOTE_DEBUG} && warn $make_sub; { no strict 'refs'; local *{$name} if $name; my ($success, $e); { local $@; $success = _clean_eval($make_sub, \%captures); $e = $@; } unless ($success) { die "Eval went very, very wrong:\n\n${make_sub}\n\n$e"; } } } $QUOTED{$sub}[3]; } sub CLONE { %QUOTED = map { defined $_ ? ($_->[4] => $_) : () } values %QUOTED; weaken($_) for values %QUOTED; } 1; __END__ =head1 NAME Sub::Quote - efficient generation of subroutines via string eval =head1 SYNOPSIS package Silly; use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub); quote_sub 'Silly::kitty', q{ print "meow" }; quote_sub 'Silly::doggy', q{ print "woof" }; my $sound = 0; quote_sub 'Silly::dagron', q{ print ++$sound % 2 ? 'burninate' : 'roar' }, { '$sound' => \$sound }; And elsewhere: Silly->kitty; # meow Silly->doggy; # woof Silly->dagron; # burninate Silly->dagron; # roar Silly->dagron; # burninate =head1 DESCRIPTION This package provides performant ways to generate subroutines from strings. =head1 SUBROUTINES =head2 quote_sub my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 }; Arguments: ?$name, $code, ?\%captures, ?\%options C<$name> is the subroutine where the coderef will be installed. C<$code> is a string that will be turned into code. C<\%captures> is a hashref of variables that will be made available to the code. The keys should be the full name of the variable to be made available, including the sigil. The values should be references to the values. The variables will contain copies of the values. See the L's C for an example using captures. =head3 options =over 2 =item * no_install B. Set this option to not install the generated coderef into the passed subroutine name on undefer. =back =head2 unquote_sub my $coderef = unquote_sub $sub; Forcibly replace subroutine with actual code. If $sub is not a quoted sub, this is a no-op. =head2 quoted_from_sub my $data = quoted_from_sub $sub; my ($name, $code, $captures, $compiled_sub) = @$data; Returns original arguments to quote_sub, plus the compiled version if this sub has already been unquoted. Note that $sub can be either the original quoted version or the compiled version for convenience. =head2 inlinify my $prelude = capture_unroll '$captures', { '$x' => 1, '$y' => 2, }; my $inlined_code = inlinify q{ my ($x, $y) = @_; print $x + $y . "\n"; }, '$x, $y', $prelude; Takes a string of code, a string of arguments, a string of code which acts as a "prelude", and a B representing whether or not to localize the arguments. =head2 capture_unroll my $prelude = capture_unroll '$captures', { '$x' => 1, '$y' => 2, }, 4; Arguments: $from, \%captures, $indent Generates a snippet of code which is suitable to be used as a prelude for L. C<$from> is a string will be used as a hashref in the resulting code. The keys of C<%captures> are the names of the variables and the values are ignored. C<$indent> is the number of spaces to indent the result by. =head1 CAVEATS Much of this is just string-based code-generation, and as a result, a few caveats apply. =head2 return Calling C from a quote_sub'ed sub will not likely do what you intend. Instead of returning from the code you defined in C, it will return from the overall function it is composited into. So when you pass in: quote_sub q{ return 1 if $condition; $morecode } It might turn up in the intended context as follows: sub foo { do { return 1 if $condition; $morecode }; } Which will obviously return from foo, when all you meant to do was return from the code context in quote_sub and proceed with running important code b. =head2 pragmas C preserves the environment of the code creating the quoted subs. This includes the package, strict, warnings, and any other lexical pragmas. This is done by prefixing the code with a block that sets up a matching environment. When inlining C subs, care should be taken that user pragmas won't effect the rest of the code. =head1 SUPPORT See L for support and contact information. =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Moo-1.004002/lib/Moo/_mro.pm000644 000765 000024 00000000134 12216242004 015534 0ustar00gknopstaff000000 000000 package Moo::_mro; if ($] >= 5.010) { require mro; } else { require MRO::Compat; } 1; Moo-1.004002/lib/Moo/_Utils.pm000644 000765 000024 00000006073 12257101143 016052 0ustar00gknopstaff000000 000000 package Moo::_Utils; no warnings 'once'; # guard against -w sub _getglob { \*{$_[0]} } sub _getstash { \%{"$_[0]::"} } use constant lt_5_8_3 => ( $] < 5.008003 or $ENV{MOO_TEST_PRE_583} ) ? 1 : 0; use constant can_haz_subname => eval { require Sub::Name }; use strictures 1; use Module::Runtime qw(use_package_optimistically module_notional_filename); use Devel::GlobalDestruction (); use base qw(Exporter); use Moo::_mro; use Config; our @EXPORT = qw( _getglob _install_modifier _load_module _maybe_load_module _get_linear_isa _getstash _install_coderef _name_coderef _unimport_coderefs _in_global_destruction _set_loaded ); sub _in_global_destruction (); *_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction; sub _install_modifier { my ($into, $type, $name, $code) = @_; if (my $to_modify = $into->can($name)) { # CMM will throw for us if not require Sub::Defer; Sub::Defer::undefer_sub($to_modify); } Class::Method::Modifiers::install_modifier(@_); } our %MAYBE_LOADED; sub _load_module { my $module = $_[0]; my $file = module_notional_filename($module); 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($_) and *$_{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); die $error; } sub _maybe_load_module { return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]}; (my $proto = $_[0]) =~ s/::/\//g; local $@; if (eval { require "${proto}.pm"; 1 }) { $MAYBE_LOADED{$_[0]} = 1; } else { if (exists $INC{"${proto}.pm"}) { warn "$_[0] exists but failed to load with error: $@"; } $MAYBE_LOADED{$_[0]} = 0; } return $MAYBE_LOADED{$_[0]}; } sub _set_loaded { $INC{Module::Runtime::module_notional_filename($_[0])} ||= $_[1]; } sub _get_linear_isa { return mro::get_linear_isa($_[0]); } sub _install_coderef { no warnings 'redefine'; *{_getglob($_[0])} = _name_coderef(@_); } sub _name_coderef { shift if @_ > 2; # three args is (target, name, sub) can_haz_subname ? Sub::Name::subname(@_) : $_[1]; } sub _unimport_coderefs { my ($target, $info) = @_; return unless $info and my $exports = $info->{exports}; my %rev = reverse %$exports; my $stash = _getstash($target); foreach my $name (keys %$exports) { if ($stash->{$name} and defined(&{$stash->{$name}})) { if ($rev{$target->can($name)}) { my $old = delete $stash->{$name}; my $full_name = join('::',$target,$name); # Copy everything except the code slot back into place (e.g. $has) foreach my $type (qw(SCALAR HASH ARRAY IO)) { next unless defined(*{$old}{$type}); no strict 'refs'; *$full_name = *{$old}{$type}; } } } } } if ($Config{useithreads}) { require Moo::HandleMoose::_TypeMap; } 1; Moo-1.004002/lib/Moo/Conflicts.pm000644 000765 000024 00000001211 12251110750 016522 0ustar00gknopstaff000000 000000 package # hide from PAUSE Moo::Conflicts; use strict; use warnings; use Dist::CheckConflicts -dist => 'Moo', -conflicts => { # enter conflicting downstream deps here, with the version indicating # the last *broken* version that *does not work*. 'HTML::Restrict' => '2.1.5', }, # these dists' ::Conflicts modules (if they exist) are also checked for # more incompatibilities -- should include all runtime prereqs here. -also => [ qw( Carp Class::Method::Modifiers strictures Module::Runtime Role::Tiny Devel::GlobalDestruction ) ], ; 1; Moo-1.004002/lib/Moo/HandleMoose/000755 000765 000024 00000000000 12260624267 016460 5ustar00gknopstaff000000 000000 Moo-1.004002/lib/Moo/HandleMoose.pm000644 000765 000024 00000015526 12260420232 017011 0ustar00gknopstaff000000 000000 package Moo::HandleMoose; use strictures 1; use Moo::_Utils; use B qw(perlstring); our %TYPE_MAP; our $SETUP_DONE; sub import { return if $SETUP_DONE; inject_all(); $SETUP_DONE = 1; } sub inject_all { require Class::MOP; inject_fake_metaclass_for($_) for grep $_ ne 'Moo::Object', do { no warnings 'once'; 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'; } 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; Class::MOP::remove_metaclass_by_name($name); my ($am_role, $meta, $attr_specs, $attr_order) = do { if (my $info = $Moo::Role::INFO{$name}) { my @attr_info = @{$info->{attributes}||[]}; (1, 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, 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, Moose::Meta::Class->initialize($name), {}, [] ) } }; for my $spec (values %$attr_specs) { if (my $inflators = delete $spec->{moosify}) { $_->($spec) for @$inflators; } } my %methods = %{($am_role ? 'Role::Tiny' : '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 # Role::Tiny cache is cleared so we don't confuse Moo itself. if (my $info = $Role::Tiny::INFO{$name}) { delete $info->{methods}; } # needed to ensure the method body is stable and get things named Sub::Defer::undefer_sub($_) for grep defined, values %methods; my @attrs; { # This local is completely not required for roles but harmless local @{_getstash($name)}{keys %methods}; my %seen_name; foreach my $name (@$attr_order) { $seen_name{$name} = 1; my %spec = %{$attr_specs->{$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->(); Scalar::Util::blessed($type) && $type->isa("Moose::Meta::TypeConstraint") or die "error inflating attribute '$name' for package '$_[0]': \$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 = perlstring($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($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 $name = delete $spec{name}; next if $seen_name{$name}++; push @attrs, $meta->add_attribute($name => %spec); } } } for my $meth_name (keys %methods) { my $meth_code = $methods{$meth_name}; $meta->add_method($meth_name, $meth_code) if $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; } } else { 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', ); # 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 do { no warnings 'once'; keys %{$Role::Tiny::APPLIED_TO{$name}} }; $DID_INJECT{$name} = 1; $meta; } 1; Moo-1.004002/lib/Moo/Object.pm000644 000765 000024 00000004046 12251013510 016011 0ustar00gknopstaff000000 000000 package Moo::Object; use strictures 1; 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); } } $NO_BUILD{$class} and return bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class); $NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class}; $NO_BUILD{$class} ? bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class) : do { my $proto = ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; bless({ %$proto }, $class)->BUILDALL($proto); }; } # Inlined into Method::Generate::Constructor::_generate_args() - keep in sync sub BUILDARGS { my $class = shift; if ( scalar @_ == 1 ) { unless ( defined $_[0] && ref $_[0] eq 'HASH' ) { die "Single parameters to new() must be a HASH ref" ." data => ". $_[0] ."\n"; } return { %{ $_[0] } }; } elsif ( @_ % 2 ) { die "The new() method for $class expects a hash reference or a key/value list." . " You passed an odd number of arguments\n"; } else { return {@_}; } } 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 { require Role::Tiny; { no warnings 'redefine'; *does = \&Role::Tiny::does_role } goto &Role::Tiny::does_role; } # duplicated in Moo::Role sub meta { require Moo::HandleMoose::FakeMetaClass; my $class = ref($_[0])||$_[0]; bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass'); } 1; Moo-1.004002/lib/Moo/Role.pm000644 000765 000024 00000030533 12260624053 015516 0ustar00gknopstaff000000 000000 package Moo::Role; use strictures 1; use Moo::_Utils; use Role::Tiny (); use base qw(Role::Tiny); use Import::Into; our $VERSION = '1.004002'; $VERSION = eval $VERSION; require Moo::sification; BEGIN { *INFO = \%Role::Tiny::INFO } our %INFO; our %APPLY_DEFAULTS; sub _install_tracked { my ($target, $name, $code) = @_; $INFO{$target}{exports}{$name} = $code; _install_coderef "${target}::${name}" => "Moo::Role::${name}" => $code; } sub import { my $target = caller; my ($me) = @_; _set_loaded(caller); strictures->import::into(1); if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) { die "Cannot import Moo::Role into a Moo class"; } $INFO{$target} ||= {}; # get symbol table reference my $stash = _getstash($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) { require Carp; Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto) . " attribute(s): even number of arguments expected, got " . scalar @_) } my %spec = @_; foreach my $name (@name_proto) { my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec; ($INFO{$target}{accessor_maker} ||= do { require Method::Generate::Accessor; Method::Generate::Accessor->new })->generate_method($target, $name, $spec_ref); push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref; $me->_maybe_reset_handlemoose($target); } }; # install before/after/around subs foreach my $type (qw(before after around)) { _install_tracked $target => $type => sub { require Class::Method::Modifiers; 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); }; return if $INFO{$target}{is_role}; # already exported into this package $INFO{$target}{is_role} = 1; *{_getglob("${target}::meta")} = $me->can('meta'); # grab all *non-constant* (stash slot is not a scalarref) subs present # in the symbol table and store their refaddrs (no need to forcibly # inflate constant subs into real subs) - also add '' to here (this # is used later) with a map to the coderefs in case of copying or re-use my @not_methods = ('', map { *$_{CODE}||() } grep !ref($_), values %$stash); @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods; # a role does itself $Role::Tiny::APPLIED_TO{$target} = { $target => undef }; if ($INC{'Moo/HandleMoose.pm'}) { Moo::HandleMoose::inject_fake_metaclass_for($target); } } # duplicate from Moo::Object sub meta { require Moo::HandleMoose::FakeMetaClass; my $class = ref($_[0])||$_[0]; bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass'); } sub unimport { my $target = caller; _unimport_coderefs($target, $INFO{$target}); } sub _maybe_reset_handlemoose { my ($class, $target) = @_; if ($INC{"Moo/HandleMoose.pm"}) { Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target); } } sub methods_provided_by { my ($self, $role) = @_; $self->_inhale_if_moose($role); die "${role} is not a Moo::Role" unless $INFO{$role}; return $self->SUPER::methods_provided_by($role); } sub _inhale_if_moose { my ($self, $role) = @_; _load_module($role); my $meta; if (!$INFO{$role} and ( $INC{"Moose.pm"} and $meta = Class::MOP::class_of($role) 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 }; $Role::Tiny::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}) { 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; $spec->{isa} = sub { &$check or die "Type constraint failed for $_[0]" }; 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 ]; } } } require Class::Method::Modifiers if @$mods; $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 role_application_steps { qw(_handle_constructor _maybe_make_accessors), $_[0]->SUPER::role_application_steps; } sub apply_roles_to_package { my ($me, $to, @roles) = @_; foreach my $role (@roles) { $me->_inhale_if_moose($role); die "${role} is not a Moo::Role" unless $INFO{$role}; } $me->SUPER::apply_roles_to_package($to, @roles); } sub apply_single_role_to_package { my ($me, $to, $role) = @_; $me->_inhale_if_moose($role); die "${role} is not a Moo::Role" unless $INFO{$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 $Role::Tiny::COMPOSED{class}{$new_name}; foreach my $role (@roles) { $me->_inhale_if_moose($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")} = [ $superclass ]; $me->apply_roles_to_package($new_name, @roles); _set_loaded($new_name, (caller)[1]); return $new_name; } require Sub::Quote; $me->SUPER::create_class_with_roles($superclass, @roles); foreach my $role (@roles) { die "${role} is not a Role::Tiny" unless $INFO{$role}; } $Moo::MAKERS{$new_name} = {is_class => 1}; $me->_handle_constructor($new_name, $_) for @roles; _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); _set_loaded(ref $new, (caller)[1]); my $apply_defaults = $APPLY_DEFAULTS{ref $new} ||= do { my %attrs = map { @{$INFO{$_}{attributes}||[]} } @roles; if ($INC{'Moo.pm'} and keys %attrs and my $con_gen = Moo->_constructor_maker_for(ref $new) and my $m = Moo->_accessor_maker_for(ref $new)) { require Sub::Quote; my $specs = $con_gen->all_attribute_specs; my $assign = ''; my %captures; foreach my $name ( keys %attrs ) { my $spec = $specs->{$name}; if ($m->has_eager_default($name, $spec)) { my ($has, $has_cap) = $m->generate_simple_has('$_[0]', $name, $spec); my ($code, $pop_cap) = $m->generate_use_default('$_[0]', $name, $spec, $has); $assign .= $code; @captures{keys %$has_cap, keys %$pop_cap} = (values %$has_cap, values %$pop_cap); } } Sub::Quote::quote_sub($assign, \%captures); } else { sub {}; } }; $new->$apply_defaults; return $new; } sub _composable_package_for { my ($self, $role) = @_; my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role; return $composed_name if $Role::Tiny::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 _handle_constructor { my ($me, $to, $role) = @_; my $attr_info = $INFO{$role} && $INFO{$role}{attributes}; return unless $attr_info && @$attr_info; if ($INFO{$to}) { push @{$INFO{$to}{attributes}||=[]}, @$attr_info; } else { # only fiddle with the constructor if the target is a Moo class if ($INC{"Moo.pm"} and my $con = Moo->_constructor_maker_for($to)) { # 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; sub foo { ... } sub bar { ... } has baz => ( is => 'ro', ); 1; And elsewhere: package Some::Class; use Moo; # bar gets imported, but not foo with('My::Role'); sub foo { ... } 1; =head1 DESCRIPTION C builds upon L, so look there for most of the documentation on how this works. The main addition here is extra bits to make the roles more "Moosey;" which is to say, it adds L. =head1 IMPORTED SUBROUTINES See L for all the other subroutines that are imported by this module. =head2 has has attr => ( is => 'ro', ); Declares an attribute for the class to be composed into. See L for all options. =head1 CLEANING UP IMPORTS L cleans up its own imported methods and any imports declared before the C statement automatically. Anything imported after C will be composed into consuming packages. A package that consumes this role: package My::Role::ID; use Digest::MD5 qw(md5_hex); use Moo::Role; use Digest::SHA qw(sha1_hex); requires 'name'; sub as_md5 { my ($self) = @_; return md5_hex($self->name); } sub as_sha1 { my ($self) = @_; return sha1_hex($self->name); } 1; ..will now have a C<< $self->sha1_hex() >> method available to it that probably does not do what you expect. On the other hand, a call to C<< $self->md5_hex() >> will die with the helpful error message: C. See L for more details. =head1 SUPPORT See L for support and contact information. =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Moo-1.004002/lib/Moo/sification.pm000644 000765 000024 00000000674 12216242004 016741 0ustar00gknopstaff000000 000000 package Moo::sification; use strictures 1; use Moo::_Utils (); sub unimport { our $disarmed = 1 } sub Moo::HandleMoose::AuthorityHack::DESTROY { unless (our $disarmed or Moo::_Utils::_in_global_destruction) { require Moo::HandleMoose; Moo::HandleMoose->import; } } if ($INC{"Moose.pm"}) { require Moo::HandleMoose; Moo::HandleMoose->import; } else { $Moose::AUTHORITY = bless({}, 'Moo::HandleMoose::AuthorityHack'); } 1; Moo-1.004002/lib/Moo/HandleMoose/_TypeMap.pm000644 000765 000024 00000002765 12260404572 020541 0ustar00gknopstaff000000 000000 package Moo::HandleMoose::_TypeMap; use strictures 1; package Moo::HandleMoose; our %TYPE_MAP; package Moo::HandleMoose::_TypeMap; use Scalar::Util (); 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 $id = do { no warnings 'portable'; hex "$1" }; require B; my $sv = bless \$id, 'B::SV'; my $ref = eval { $sv->object_2svref }; if (!defined $ref) { 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; } my @types = %TYPE_MAP; tie %TYPE_MAP, __PACKAGE__; %TYPE_MAP = @types; 1; Moo-1.004002/lib/Moo/HandleMoose/FakeMetaClass.pm000644 000765 000024 00000000741 12216242004 021445 0ustar00gknopstaff000000 000000 package Moo::HandleMoose::FakeMetaClass; sub DESTROY { } sub AUTOLOAD { my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/); require Moo::HandleMoose; Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->$meth(@_) } sub can { require Moo::HandleMoose; Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->can(@_) } sub isa { require Moo::HandleMoose; Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->isa(@_) } sub make_immutable { $_[0] } 1; Moo-1.004002/lib/Method/Generate/000755 000765 000024 00000000000 12260624267 016502 5ustar00gknopstaff000000 000000 Moo-1.004002/lib/Method/Inliner.pm000644 000765 000024 00000002563 12217442553 016712 0ustar00gknopstaff000000 000000 package Method::Inliner; use strictures 1; use Text::Balanced qw(extract_bracketed); use Sub::Quote (); sub slurp { do { local (@ARGV, $/) = $_[0]; <> } } sub splat { open my $out, '>', $_[1] or die "can't open $_[1]: $!"; print $out $_[0] or die "couldn't write to $_[1]: $!"; } sub inlinify { my $file = $_[0]; my @chunks = split /(^sub.*?^}$)/sm, slurp $file; warn join "\n--\n", @chunks; my %code; foreach my $chunk (@chunks) { if (my ($name, $body) = $chunk =~ /^sub (\S+) {\n(.*)\n}$/s ) { $code{$name} = $body; } } foreach my $chunk (@chunks) { my ($me) = $chunk =~ /^sub.*{\n my \((\$\w+).*\) = \@_;\n/ or next; my $meq = quotemeta $me; #warn $meq, $chunk; my $copy = $chunk; my ($fixed, $rest); while ($copy =~ s/^(.*?)${meq}->(\S+)(?=\()//s) { my ($front, $name) = ($1, $2); ((my $body), $rest) = extract_bracketed($copy, '()'); warn "spotted ${name} - ${body}"; if ($code{$name}) { warn "replacing"; s/^\(//, s/\)$// for $body; $body = "${me}, ".$body; $fixed .= $front.Sub::Quote::inlinify($code{$name}, $body); } else { $fixed .= $front.$me.'->'.$name.$body; } #warn $fixed; warn $rest; $copy = $rest; } $fixed .= $rest if $fixed; warn $fixed if $fixed; $chunk = $fixed if $fixed; } print join '', @chunks; } 1; Moo-1.004002/lib/Method/Generate/Accessor.pm000644 000765 000024 00000045016 12257101143 020575 0ustar00gknopstaff000000 000000 package Method::Generate::Accessor; use strictures 1; use Moo::_Utils; use base qw(Moo::Object); use Sub::Quote; use B 'perlstring'; use Scalar::Util 'blessed'; use overload (); use Module::Runtime qw(use_module); BEGIN { 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') }) ; } sub _SIGDIE { our ($CurrentAttribute, $OrigSigDie); my $sigdie = $OrigSigDie && $OrigSigDie != \&_SIGDIE ? $OrigSigDie : sub { die $_[0] }; return $sigdie->(@_) if ref($_[0]); my $attr_desc = _attr_desc(@$CurrentAttribute{qw(name init_arg)}); $sigdie->("$CurrentAttribute->{step} for $attr_desc failed: $_[0]"); } sub _die_overwrite { my ($pkg, $method, $type) = @_; die "You cannot overwrite a locally defined method ($method) with @{[ $type || 'an accessor' ]}"; } sub generate_method { my ($self, $into, $name, $spec, $quote_opts) = @_; $spec->{allow_overwrite}++ if $name =~ s/^\+//; die "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 $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') { die "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; die "Invalid builder for $into->$name - not a valid method name" if $spec->{builder} !~ /\A[A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z_][A-Za-z0-9_]*)*\z/; } 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.'(@_)'); } for my $setting (qw( isa coerce )) { next if !exists $spec->{$setting}; $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name"); } if (exists $spec->{default}) { if (!defined $spec->{default} || 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}]; } for 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} && *{_getglob("${into}::${reader}")}{CODE}; 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}" => ' die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n" .$self->_generate_get($name, $spec) => delete $self->{captures} ; } } if (my $accessor = $spec->{accessor}) { _die_overwrite($into, $accessor, 'an accessor') if !$spec->{allow_overwrite} && *{_getglob("${into}::${accessor}")}{CODE}; 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} ; } } if (my $writer = $spec->{writer}) { _die_overwrite($into, $writer, 'a writer') if !$spec->{allow_overwrite} && *{_getglob("${into}::${writer}")}{CODE}; 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} ; } } if (my $pred = $spec->{predicate}) { _die_overwrite($into, $pred, 'a predicate') if !$spec->{allow_overwrite} && *{_getglob("${into}::${pred}")}{CODE}; if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) { $methods{$pred} = $self->_generate_xs( exists_predicates => $into, $pred, $name, $spec ); } else { $methods{$pred} = quote_sub "${into}::${pred}" => ' '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n" ; } } if (my $pred = $spec->{builder_sub}) { _install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} ); } if (my $cl = $spec->{clearer}) { _die_overwrite($into, $cl, 'a clearer') if !$spec->{allow_overwrite} && *{_getglob("${into}::${cl}")}{CODE}; $methods{$cl} = quote_sub "${into}::${cl}" => $self->_generate_simple_clear('$_[0]', $name, $spec)."\n" ; } 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)) { map [ $_ => $_ ], use_module('Moo::Role')->methods_provided_by(use_module($hspec)) } else { die "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} && *{_getglob("${into}::${proxy}")}{CODE}; $self->{captures} = {}; $methods{$proxy} = quote_sub "${into}::${proxy}" => $self->_generate_delegation($asserter, $target, \@args), delete $self->{captures} ; } } if (my $asserter = $spec->{asserter}) { $self->{captures} = {}; $methods{$asserter} = quote_sub "${into}::${asserter}" => $self->_generate_asserter($name, $spec), delete $self->{captures} ; } \%methods; } 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 ($spec->{default} or $spec->{builder})); } sub is_simple_set { my ($self, $name, $spec) = @_; !grep $spec->{$_}, qw(coerce isa trigger weak_ref); } 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}->{${\perlstring $name}}"; } sub _generate_simple_clear { my ($self, $me, $name) = @_; " delete ${me}->{${\perlstring $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}) : perlstring $spec->{default}; } else { "${me}->${\$spec->{builder}}" } } sub generate_simple_get { my ($self, @args) = @_; $self->_generate_simple_get(@args); } sub _generate_simple_get { my ($self, $me, $name) = @_; my $name_str = perlstring $name; "${me}->{${name_str}}"; } sub _generate_set { my ($self, $name, $spec) = @_; if ($self->is_simple_set($name, $spec)) { $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]'); } else { my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)}; my $value_store = '$_[0]'; my $code; if ($coerce) { $value_store = '$value'; $code = "do { my (\$self, \$value) = \@_;\n" ." \$value = " .$self->_generate_coerce($name, $value_store, $coerce).";\n"; } else { $code = "do { my \$self = shift;\n"; } if ($isa_check) { $code .= " ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n"; } my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store); if ($trigger) { my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger); $code .= " ".$simple.";\n ".$fire.";\n" ." $value_store;\n"; } else { $code .= " ".$simple.";\n"; } $code .= " }"; $code; } } 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 perlstring($name) if !defined($init_arg) or $init_arg eq $name; return perlstring($name).' (constructor argument: '.perlstring($init_arg).')'; } sub _generate_coerce { my ($self, $name, $value, $coerce, $init_arg) = @_; $self->_generate_die_prefix( $name, "coercion", $init_arg, $self->_generate_call_code($name, 'coerce', "${value}", $coerce) ); } 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 _generate_die_prefix { my ($self, $name, $prefix, $arg, $inside) = @_; "do {\n" .' local $Method::Generate::Accessor::CurrentAttribute = {' .' init_arg => '.(defined $arg ? B::perlstring($arg) : 'undef') . ",\n" .' name => '.B::perlstring($name).",\n" .' step => '.B::perlstring($prefix).",\n" ." };\n" .' local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n" .' local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n" .$inside ."}\n" } sub _generate_isa_check { my ($self, $name, $value, $check, $init_arg) = @_; $self->_generate_die_prefix( $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_}.$self->_sanitize_name($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_}.$self->_sanitize_name($name); $self->{captures}->{$cap_name} = \$sub; "${cap_name}->(${values})"; } } sub _sanitize_name { my ($self, $name) = @_; $name =~ s/([_\W])/sprintf('_%x', ord($1))/ge; $name; } 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) = @_; if ($self->has_eager_default($name, $spec)) { my $get_indent = ' ' x ($spec->{isa} ? 6 : 4); my $get_default = $self->_generate_get_default( '$new', $name, $spec ); my $get_value = defined($spec->{init_arg}) ? "(\n${get_indent} ${test}\n${get_indent} ? ${source}\n${get_indent} : " .$get_default ."\n${get_indent})" : $get_default; if ($spec->{coerce}) { $get_value = $self->_generate_coerce( $name, $get_value, $spec->{coerce}, $init_arg ) } ($spec->{isa} ? " {\n my \$value = ".$get_value.";\n " .$self->_generate_isa_check( $name, '$value', $spec->{isa}, $init_arg ).";\n" .' '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n" ." }\n" : ' '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n" ) .($spec->{trigger} ? ' ' .$self->_generate_trigger( $name, $me, $self->_generate_simple_get($me, $name, $spec), $spec->{trigger} )." if ${test};\n" : '' ); } else { " if (${test}) {\n" .($spec->{coerce} ? " $source = " .$self->_generate_coerce( $name, $source, $spec->{coerce}, $init_arg ).";\n" : "" ) .($spec->{isa} ? " " .$self->_generate_isa_check( $name, $source, $spec->{isa}, $init_arg ).";\n" : "" ) ." ".$self->_generate_simple_set($me, $name, $spec, $source).";\n" .($spec->{trigger} ? " " .$self->_generate_trigger( $name, $me, $self->_generate_simple_get($me, $name, $spec), $spec->{trigger} ).";\n" : "" ) ." }\n"; } } sub _generate_core_set { my ($self, $me, $name, $spec, $value) = @_; my $name_str = perlstring $name; "${me}->{${name_str}} = ${value}"; } sub _generate_simple_set { my ($self, $me, $name, $spec, $value) = @_; my $name_str = perlstring $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::SetReadWrite($foo); #Scalar::Util::weaken ($foo); #Internals::SetReadOnly($foo); # # but requires XS and is just too damn crazy # so simply throw a better exception my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }"; Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple; 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) = @_; "do {\n" ." my \$val = ".$self->_generate_get($name, $spec).";\n" ." unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n" .qq! die "Attempted to access '${name}' but it is not set";\n! ." }\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 perlstring # 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 $invalid = "Invalid $setting '" . overload::StrVal($value) . "' for $into not a coderef"; $invalid .= " $appended" if $appended; unless (ref $value and (ref $value eq 'CODE' or blessed($value))) { die "$invalid or code-convertible object"; } unless (eval { \&$value }) { die "$invalid and could not be converted to a coderef: $@"; } 1; } 1; Moo-1.004002/lib/Method/Generate/BuildAll.pm000644 000765 000024 00000001450 12251013467 020522 0ustar00gknopstaff000000 000000 package Method::Generate::BuildAll; use strictures 1; use base qw(Moo::Object); use Sub::Quote; use Moo::_Utils; use B 'perlstring'; 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}; } sub _handle_subbuild { my ($self, $into) = @_; ' if (ref($_[0]) ne '.perlstring($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 @{Moo::_Utils::_get_linear_isa($into)}; join '', map qq{ ${me}->${_}(${args});\n}, @builds; } 1; Moo-1.004002/lib/Method/Generate/Constructor.pm000644 000765 000024 00000013301 12257120152 021351 0ustar00gknopstaff000000 000000 package Method::Generate::Constructor; use strictures 1; use Sub::Quote; use base qw(Moo::Object); use Sub::Defer; use B 'perlstring'; use Moo::_Utils qw(_getstash); sub register_attribute_specs { my ($self, @new_specs) = @_; my $specs = $self->{attribute_specs}||={}; while (my ($name, $new_spec) = splice @new_specs, 0, 2) { if ($name =~ s/^\+//) { die "has '+${name}' given but no ${name} attribute already exists" unless my $old_spec = $specs->{$name}; foreach my $key (keys %$old_spec) { if (!exists $new_spec->{$key}) { $new_spec->{$key} = $old_spec->{$key} unless $key eq 'handles'; } elsif ($key eq 'moosify') { $new_spec->{$key} = [ map { ref $_ eq 'ARRAY' ? @$_ : $_ } ($old_spec->{$key}, $new_spec->{$key}) ]; } } } if (exists $new_spec->{init_arg} && !defined $new_spec->{init_arg} && $new_spec->{required}) { die "${name} attribute can't be required with init_arg => undef"; } $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) = @_; my $package = $self->{package}; defer_sub "${package}::new" => sub { unquote_sub $self->generate_method( $package, 'new', $self->{attribute_specs}, { no_install => 1 } ) }; $self; } sub generate_method { my ($self, $into, $name, $spec, $quote_opts) = @_; foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) { $spec->{$no_init}{init_arg} = $no_init; } local $self->{captures} = {}; my $body = ' my $class = shift;'."\n" .' $class = ref($class) if ref($class);'."\n"; $body .= $self->_handle_subconstructor($into, $name); my $into_buildargs = $into->can('BUILDARGS'); if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) { $body .= $self->_generate_args_via_buildargs; } else { $body .= $self->_generate_args; } $body .= $self->_check_required($spec); $body .= ' my $new = '.$self->construction_string.";\n"; $body .= $self->_assign_new($spec); if ($into->can('BUILD')) { $body .= $self->buildall_generator->buildall_body_for( $into, '$new', '$args' ); } $body .= ' 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 '.perlstring($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{ die "BUILDARGS did not return a hashref" unless ref($args) eq 'HASH';} ."\n"; } # inlined from Moo::Object - update that first. sub _generate_args { my ($self) = @_; return <<'_EOA'; my $args; if ( scalar @_ == 1 ) { unless ( defined $_[0] && ref $_[0] eq 'HASH' ) { die "Single parameters to new() must be a HASH ref" ." data => ". $_[0] ."\n"; } $args = { %{ $_[0] } }; } elsif ( @_ % 2 ) { die "The new() method for $class expects a hash reference or a key/value list." . " You passed an odd number of arguments\n"; } else { $args = {@_}; } _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_key = perlstring($test{$_}); my $test = "exists \$args->{$arg_key}"; my $source = "\$args->{$arg_key}"; my $attr_spec = $spec->{$_}; $self->_cap_call($ag->generate_populate_set( '$new', $_, $attr_spec, $source, $test, $test{$_}, )); } 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 $s{default}) } sort keys %$spec; return '' unless @required_init; ' if (my @missing = grep !exists $args->{$_}, qw(' .join(' ',@required_init).')) {'."\n" .q{ die "Missing required arguments: ".join(', ', sort @missing);}."\n" ." }\n"; } use Moo; 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 => 'lazy' }, subconstructor_handler => { is => 'ro' }, package => { is => 'ro' }, ); 1; Moo-1.004002/lib/Method/Generate/DemolishAll.pm000644 000765 000024 00000002171 12251013467 021230 0ustar00gknopstaff000000 000000 package Method::Generate::DemolishAll; use strictures 1; use base qw(Moo::Object); use Sub::Quote; use Moo::_Utils; use B qw(perlstring); sub generate_method { my ($self, $into) = @_; quote_sub "${into}::DEMOLISHALL", join '', $self->_handle_subdemolish($into), qq{ my \$self = shift;\n}, $self->demolishall_body_for($into, '$self', '@_'), qq{ return \$self\n}; quote_sub "${into}::DESTROY", join '', q! my $self = shift; my $e = do { local $?; local $@; require Moo::_Utils; eval { $self->DEMOLISHALL(Moo::_Utils::_in_global_destruction); }; $@; }; no warnings 'misc'; die $e if $e; # rethrow !; } sub demolishall_body_for { my ($self, $into, $me, $args) = @_; my @demolishers = grep *{_getglob($_)}{CODE}, map "${_}::DEMOLISH", @{Moo::_Utils::_get_linear_isa($into)}; join '', map qq{ ${me}->${_}(${args});\n}, @demolishers; } sub _handle_subdemolish { my ($self, $into) = @_; ' if (ref($_[0]) ne '.perlstring($into).') {'."\n". ' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n". ' }'."\n"; } 1; Moo-1.004002/bin/moo-outdated000644 000765 000024 00000000547 12251110750 016047 0ustar00gknopstaff000000 000000 #!/usr/bin/perl use strict; use warnings; # PODNAME: moo-outdated use Getopt::Long; use Moo::Conflicts; my $verbose; GetOptions( 'verbose|v' => \$verbose ); if ($verbose) { Moo::Conflicts->check_conflicts; } else { my @conflicts = Moo::Conflicts->calculate_conflicts; print "$_\n" for map { $_->{package} } @conflicts; exit @conflicts; }